* [Patch, fortran, PR44672, v1] [F08] ALLOCATE with SOURCE and no array-spec
@ 2015-03-30 17:48 Andre Vehreschild
2015-04-01 13:15 ` [Patch, fortran, PR44672, v2] " Andre Vehreschild
0 siblings, 1 reply; 21+ messages in thread
From: Andre Vehreschild @ 2015-03-30 17:48 UTC (permalink / raw)
To: GCC-Patches-ML, GCC-Fortran-ML, Antony Lewis
[-- Attachment #1: Type: text/plain, Size: 632 bytes --]
Dear all,
please find attach a patch fixing pr44672:
integer, dimension(:) :: arr
allocate(arr, source = [1,2,3])
as for F2008:C633 now is no longer flagged, beside when you insist on
-std=f2003 or lower. Furthermore does the patch implement the F2008 feature of
obsoleting the explicit array specification on the arrays to allocate, when
an array valued source=/mold= expression is given.
Bootstrap and regtests ok on x86_64-linux-gnu/F20.
This batched is based on a trunk having my latest for pr60322 patched in (else
deltas may occur).
Ok for 5.2 trunk?
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr44672_1.clog --]
[-- Type: application/octet-stream, Size: 1226 bytes --]
gcc/testsuite/ChangeLog:
2015-03-30 Andre Vehreschild <vehre@gmx.de>
* gfortran.dg/allocate_with_source_3.f90: Enhanced to
check implementation of F2008:C633.
gcc/fortran/ChangeLog:
2015-03-30 Andre Vehreschild <vehre@gmx.de>
PR fortran/44672
* 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. Generate temporay variable assignment to
allow source-expressions without explicit array
specification.
* trans-array.c (gfc_array_init_size): Get lower and
upper bound from a tree array descriptor.
(retrieve_last_ref): Extracted from gfc_array_allocate().
(gfc_array_allocate): Enable allocate(array, source=
array_expression) as specified by F2008:C633.
* trans-array.h: Add temporary array descriptor to
gfc_array_allocate ().
* 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.
[-- Attachment #3: pr44672_1.patch --]
[-- Type: text/x-patch, Size: 18162 bytes --]
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 643cd6a..9835edc 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2394,6 +2394,9 @@ typedef struct gfc_code
{
gfc_typespec ts;
gfc_alloc *list;
+ /* Take the array specification from expr3 to allocate arrays
+ without an explicit array specification. */
+ unsigned arr_spec_from_expr3:1;
}
alloc;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 316b413..73ac873 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6804,7 +6804,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
have a trailing array reference that gives the size of the array. */
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 codimension;
@@ -7103,9 +7103,20 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
|| (dimension && ref2->u.ar.dimen == 0))
{
- gfc_error ("Array specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
+ /* F08:C633. */
+ if (code->expr3)
+ {
+ 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
@@ -7124,7 +7135,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
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;
switch (ar->dimen_type[i])
@@ -7201,6 +7212,12 @@ failure:
return false;
}
+
+static gfc_code *
+build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
+ gfc_component *comp1, gfc_component *comp2, locus loc);
+
+
static void
resolve_allocate_deallocate (gfc_code *code, const char *fcn)
{
@@ -7375,8 +7392,103 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
if (strcmp (fcn, "ALLOCATE") == 0)
{
+ bool arr_alloc_wo_spec = false;
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;
+
+ if (code->expr3->expr_type == EXPR_ARRAY
+ || code->expr3->expr_type == EXPR_FUNCTION)
+ {
+ /* The trans stage can not cope with expr3->expr_type
+ being EXPR_ARRAY or EXPR_FUNCTION, therefore create a
+ temporary variable and assign expr3 to it, substituting
+ the variable in expr3. */
+ char name[25];
+ static unsigned int alloc_sym_count = 0;
+ gfc_symbol *temp_var_sym;
+ gfc_expr *temp_var;
+ gfc_code *ass, *iter;
+ gfc_namespace *ns = code->ext.alloc.list->expr->symtree->n.sym->ns;
+ gfc_array_spec *as;
+ int dim;
+ mpz_t dim_size;
+
+ /* The name of the new variable. */
+ sprintf (name, "alloc_arr_init.%d", alloc_sym_count++);
+ gfc_get_symbol (name, ns, &temp_var_sym);
+ temp_var_sym->attr.artificial = 1;
+ temp_var_sym->attr.flavor = FL_VARIABLE;
+ temp_var_sym->ts = code->expr3->ts;
+ /* Build an EXPR_VARIABLE node. */
+ temp_var = gfc_get_expr ();
+ temp_var->expr_type = EXPR_VARIABLE;
+ temp_var->symtree = gfc_find_symtree (ns->sym_root, name);
+ temp_var->ts = code->expr3->ts;
+ temp_var->where = code->expr3->where;
+
+ /* Now to the most important: Set the array specification
+ correctly. */
+ as = gfc_get_array_spec ();
+ temp_var->rank = as->rank = code->expr3->rank;
+ if (code->expr3->expr_type == EXPR_ARRAY)
+ {
+ /* For EXPR_ARRAY the as can be deduced from the shape. */
+ as->type = AS_EXPLICIT;
+ for (dim = 0; dim < as->rank; ++dim)
+ {
+ gfc_array_dimen_size (code->expr3, dim, &dim_size);
+ as->lower[dim] = gfc_get_int_expr (gfc_index_integer_kind,
+ &code->expr3->where, 1);
+ as->upper[dim] = gfc_get_int_expr (gfc_index_integer_kind,
+ &code->expr3->where,
+ mpz_get_si (dim_size));
+ }
+ }
+ else if (code->expr3->expr_type == EXPR_FUNCTION)
+ {
+ /* For functions this is far more complicated. */
+ as->type = AS_DEFERRED;
+ temp_var_sym->attr.allocatable = 1;
+ }
+ else
+ gcc_unreachable ();
+
+ temp_var_sym->as = as;
+ temp_var_sym->attr.dimension = 1;
+ gfc_add_full_array_ref (temp_var, as);
+
+ ass = gfc_get_code (EXEC_ASSIGN);
+ ass->expr1 = gfc_copy_expr (temp_var);
+ ass->expr2 = code->expr3;
+ ass->loc = code->expr3->where;
+
+ gfc_resolve_code (ass, ns);
+ /* Now add the new code before this ones. */
+ iter = ns->code;
+ /* At least one code has to be present in the ns, this one. */
+ if (iter == code)
+ ns->code = ass;
+ else
+ {
+ while (iter->next && iter->next != code)
+ iter = iter->next;
+ gcc_assert (iter->next);
+ iter->next = ass;
+ }
+ ass->next = code;
+
+ /* Do not gfc_free_expr (temp_var), because it is inserted
+ without copy into expr3. */
+ code->expr3 = temp_var;
+ gfc_set_sym_referenced (temp_var_sym);
+ }
+ }
}
else
{
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0804d45..e1f9e42 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4981,7 +4981,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
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)
{
tree type;
tree tmp;
@@ -5024,20 +5025,25 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set lower bound. */
gfc_init_se (&se, NULL);
- if (lower == NULL)
- se.expr = gfc_index_one_node;
+ if (expr3_desc != NULL_TREE)
+ se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, gfc_rank_cst[n]);
else
{
- gcc_assert (lower[n]);
- if (ubound)
- {
- gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- }
+ if (lower == NULL)
+ se.expr = gfc_index_one_node;
else
{
- se.expr = gfc_index_one_node;
- ubound = lower[n];
+ gcc_assert (lower[n]);
+ if (ubound)
+ {
+ gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ }
+ else
+ {
+ se.expr = gfc_index_one_node;
+ ubound = lower[n];
+ }
}
}
gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
@@ -5052,10 +5058,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set upper bound. */
gfc_init_se (&se, NULL);
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
-
+ if (expr3_desc != NULL_TREE)
+ 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_rank_cst[n], se.expr);
conv_ubound = se.expr;
@@ -5225,6 +5235,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
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
@@ -5232,7 +5269,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3)
+ tree *nelems, gfc_expr *expr3, tree e3_arr_desc)
{
tree tmp;
tree pointer;
@@ -5250,21 +5287,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable, coarray, dimension;
+ bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
/* 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
- || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
- prev_ref = ref;
- ref = ref->next;
- }
+ /* F08:C633: Array shape from expr3. */
+ ref = expr3->ref;
- if (ref == NULL || ref->type != REF_ARRAY)
- return false;
+ /* Find the last reference in the chain. */
+ if (!retrieve_last_ref (&ref, &prev_ref))
+ return false;
+ alloc_w_e3_arr_spec = true;
+ }
if (!prev_ref)
{
@@ -5300,7 +5340,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
break;
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;
upper = ref->u.ar.as->upper;
@@ -5317,7 +5358,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3);
+ expr3_elem_size, nelems, expr3, e3_arr_desc);
if (dimension)
{
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 8544534..389a644 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -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
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *);
+ tree, tree *, gfc_expr *, tree);
/* 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 *,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 68b343b..8da5420 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -4974,7 +4974,7 @@ gfc_trans_allocate (gfc_code * code)
element size, i.e. _vptr%size, is stored in expr3_esize. Any of
the trees may be the NULL_TREE indicating that this is not
available for expr3's type. */
- tree expr3, expr3_vptr, expr3_len, expr3_esize;
+ tree expr3, expr3_vptr, expr3_len, expr3_esize, expr3_desc;
stmtblock_t block;
stmtblock_t post;
tree nelems;
@@ -4986,6 +4986,7 @@ gfc_trans_allocate (gfc_code * code)
stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+ expr3_desc = NULL_TREE;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -5040,12 +5041,13 @@ gfc_trans_allocate (gfc_code * code)
/* A array expr3 needs the scalarizer, therefore do not process it
here. */
- if (code->expr3->expr_type != EXPR_ARRAY
- && (code->expr3->rank == 0
- || code->expr3->expr_type == EXPR_FUNCTION)
- && (!code->expr3->symtree
- || !code->expr3->symtree->n.sym->as)
- && !gfc_is_class_array_ref (code->expr3, NULL))
+ if (code->ext.alloc.arr_spec_from_expr3
+ || (code->expr3->expr_type != EXPR_ARRAY
+ && (code->expr3->rank == 0
+ || code->expr3->expr_type == EXPR_FUNCTION)
+ && (!code->expr3->symtree
+ || !code->expr3->symtree->n.sym->as)
+ && !gfc_is_class_array_ref (code->expr3, NULL)))
{
/* When expr3 is a variable, i.e., a very simple expression,
then convert it once here. */
@@ -5054,16 +5056,25 @@ gfc_trans_allocate (gfc_code * code)
{
if (!code->expr3->mold
|| code->expr3->ts.type == BT_CHARACTER
- || vtab_needed)
+ || vtab_needed
+ || code->ext.alloc.arr_spec_from_expr3)
{
/* Convert expr3 to a tree. */
gfc_init_se (&se, NULL);
se.want_pointer = 1;
- gfc_conv_expr (&se, code->expr3);
+ if (code->ext.alloc.arr_spec_from_expr3)
+ {
+ gfc_conv_expr_descriptor (&se, code->expr3);
+ se.expr = build_fold_indirect_ref (se.expr);
+ }
+ else
+ gfc_conv_expr (&se, code->expr3);
if (!code->expr3->mold)
expr3 = se.expr;
else
expr3_tmp = se.expr;
+ if (code->ext.alloc.arr_spec_from_expr3)
+ expr3_desc = se.expr;
expr3_len = se.string_length;
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
@@ -5102,6 +5113,8 @@ gfc_trans_allocate (gfc_code * code)
expr3 = tmp;
else
expr3_tmp = tmp;
+ if (code->ext.alloc.arr_spec_from_expr3)
+ expr3_desc = tmp;
/* When he length of a char array is easily available
here, fix it for future use. */
if (se.string_length)
@@ -5297,7 +5310,8 @@ gfc_trans_allocate (gfc_code * code)
else
tmp = expr3_esize;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems, code->expr3))
+ label_finish, tmp, &nelems,
+ code->expr3, expr3_desc))
{
/* A scalar or derived type. First compute the size to
allocate.
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
index f7e0109..d2ff2c0 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
@@ -1,28 +1,80 @@
-! { dg-do compile }
+! { dg-do run }
!
! Contributed by Reinhold Bader
!
program assumed_shape_01
- use, intrinsic :: iso_c_binding
implicit none
- type, bind(c) :: cstruct
- integer(c_int) :: i
- real(c_float) :: r(2)
+ type :: cstruct
+ integer :: i
+ real :: r(2)
end type cstruct
- interface
- subroutine psub(this, that) bind(c, name='Psub')
- import :: c_float, cstruct
- real(c_float) :: this(:,:)
- type(cstruct) :: that(:)
- end subroutine psub
- end interface
-
- real(c_float) :: t(3,7)
+
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 (u(1)%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)
-! 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" }
- call psub(t, u)
+ 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)
+contains
+ function arrval()
+ integer, dimension(5) :: arrval
+ arrval = [ 1, 2, 4, 5, 6]
+ end function
end program assumed_shape_01
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v2] [F08] ALLOCATE with SOURCE and no array-spec
2015-03-30 17:48 [Patch, fortran, PR44672, v1] [F08] ALLOCATE with SOURCE and no array-spec Andre Vehreschild
@ 2015-04-01 13:15 ` Andre Vehreschild
2015-04-02 9:03 ` [Patch, fortran, PR44672, v3] " Andre Vehreschild
0 siblings, 1 reply; 21+ messages in thread
From: Andre Vehreschild @ 2015-04-01 13:15 UTC (permalink / raw)
To: GCC-Patches-ML, GCC-Fortran-ML, Antony Lewis
[-- Attachment #1: Type: text/plain, Size: 1064 bytes --]
Hi all,
during debugging another fortran code, I figured that some cases were not yet
met. Especially the case where a class array is in the source= or mold=
expression. This new version of the patch fixes the issue now.
Bootstraps and regtests ok on x86_64-linux-gnu/F20.
Ok for 5.2 trunk?
Regards,
Andre
On Mon, 30 Mar 2015 19:47:49 +0200
Andre Vehreschild <vehre@gmx.de> wrote:
> Dear all,
>
> please find attach a patch fixing pr44672:
>
> integer, dimension(:) :: arr
> allocate(arr, source = [1,2,3])
>
> as for F2008:C633 now is no longer flagged, beside when you insist on
> -std=f2003 or lower. Furthermore does the patch implement the F2008 feature of
> obsoleting the explicit array specification on the arrays to allocate, when
> an array valued source=/mold= expression is given.
>
> Bootstrap and regtests ok on x86_64-linux-gnu/F20.
>
> This batched is based on a trunk having my latest for pr60322 patched in (else
> deltas may occur).
>
> Ok for 5.2 trunk?
>
> Regards,
> Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr44672_2.clog --]
[-- Type: application/octet-stream, Size: 444 bytes --]
gcc/testsuite/ChangeLog:
2015-04-01 Andre Vehreschild <vehre@gmx.de>
* gfortran.dg/allocate_with_source_3.f90:
gcc/fortran/ChangeLog:
2015-04-01 Andre Vehreschild <vehre@gmx.de>
* gfortran.h:
* resolve.c (resolve_allocate_expr):
(resolve_allocate_deallocate):
* trans-array.c (gfc_array_init_size):
(retrieve_last_ref):
(gfc_array_allocate):
(gfc_conv_expr_descriptor):
* trans-array.h:
* trans-stmt.c (gfc_trans_allocate):
[-- Attachment #3: pr44672_2.patch --]
[-- Type: text/x-patch, Size: 20907 bytes --]
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 643cd6a..9835edc 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2394,6 +2394,9 @@ typedef struct gfc_code
{
gfc_typespec ts;
gfc_alloc *list;
+ /* Take the array specification from expr3 to allocate arrays
+ without an explicit array specification. */
+ unsigned arr_spec_from_expr3:1;
}
alloc;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 316b413..ce2e29e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6804,7 +6804,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
have a trailing array reference that gives the size of the array. */
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 codimension;
@@ -7103,9 +7103,20 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
|| (dimension && ref2->u.ar.dimen == 0))
{
- gfc_error ("Array specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
+ /* F08:C633. */
+ if (code->expr3)
+ {
+ 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
@@ -7124,7 +7135,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
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;
switch (ar->dimen_type[i])
@@ -7375,8 +7386,103 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
if (strcmp (fcn, "ALLOCATE") == 0)
{
+ bool arr_alloc_wo_spec = false;
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;
+
+ if (code->expr3->expr_type == EXPR_ARRAY
+ || code->expr3->expr_type == EXPR_FUNCTION)
+ {
+ /* The trans stage can not cope with expr3->expr_type
+ being EXPR_ARRAY or EXPR_FUNCTION, therefore create a
+ temporary variable and assign expr3 to it, substituting
+ the variable in expr3. */
+ char name[25];
+ static unsigned int alloc_sym_count = 0;
+ gfc_symbol *temp_var_sym;
+ gfc_expr *temp_var;
+ gfc_code *ass, *iter;
+ gfc_namespace *ns = code->ext.alloc.list->expr->symtree->n.sym->ns;
+ gfc_array_spec *as;
+ int dim;
+ mpz_t dim_size;
+
+ /* The name of the new variable. */
+ sprintf (name, "alloc_arr_init.%d", alloc_sym_count++);
+ gfc_get_symbol (name, ns, &temp_var_sym);
+ temp_var_sym->attr.artificial = 1;
+ temp_var_sym->attr.flavor = FL_VARIABLE;
+ temp_var_sym->ts = code->expr3->ts;
+ /* Build an EXPR_VARIABLE node. */
+ temp_var = gfc_get_expr ();
+ temp_var->expr_type = EXPR_VARIABLE;
+ temp_var->symtree = gfc_find_symtree (ns->sym_root, name);
+ temp_var->ts = code->expr3->ts;
+ temp_var->where = code->expr3->where;
+
+ /* Now to the most important: Set the array specification
+ correctly. */
+ as = gfc_get_array_spec ();
+ temp_var->rank = as->rank = code->expr3->rank;
+ if (code->expr3->expr_type == EXPR_ARRAY)
+ {
+ /* For EXPR_ARRAY the as can be deduced from the shape. */
+ as->type = AS_EXPLICIT;
+ for (dim = 0; dim < as->rank; ++dim)
+ {
+ gfc_array_dimen_size (code->expr3, dim, &dim_size);
+ as->lower[dim] = gfc_get_int_expr (gfc_index_integer_kind,
+ &code->expr3->where, 1);
+ as->upper[dim] = gfc_get_int_expr (gfc_index_integer_kind,
+ &code->expr3->where,
+ mpz_get_si (dim_size));
+ }
+ }
+ else if (code->expr3->expr_type == EXPR_FUNCTION)
+ {
+ /* For functions this is far more complicated. */
+ as->type = AS_DEFERRED;
+ temp_var_sym->attr.allocatable = 1;
+ }
+ else
+ gcc_unreachable ();
+
+ temp_var_sym->as = as;
+ temp_var_sym->attr.dimension = 1;
+ gfc_add_full_array_ref (temp_var, as);
+
+ ass = gfc_get_code (EXEC_ASSIGN);
+ ass->expr1 = gfc_copy_expr (temp_var);
+ ass->expr2 = code->expr3;
+ ass->loc = code->expr3->where;
+
+ gfc_resolve_code (ass, ns);
+ /* Now add the new code before this ones. */
+ iter = ns->code;
+ /* At least one code has to be present in the ns, this one. */
+ if (iter == code)
+ ns->code = ass;
+ else
+ {
+ while (iter->next && iter->next != code)
+ iter = iter->next;
+ gcc_assert (iter->next);
+ iter->next = ass;
+ }
+ ass->next = code;
+
+ /* Do not gfc_free_expr (temp_var), because it is inserted
+ without copy into expr3. */
+ code->expr3 = temp_var;
+ gfc_set_sym_referenced (temp_var_sym);
+ }
+ }
}
else
{
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0804d45..f1db69c 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4981,7 +4981,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
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)
{
tree type;
tree tmp;
@@ -5024,20 +5025,25 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set lower bound. */
gfc_init_se (&se, NULL);
- if (lower == NULL)
- se.expr = gfc_index_one_node;
+ if (expr3_desc != NULL_TREE)
+ se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, gfc_rank_cst[n]);
else
{
- gcc_assert (lower[n]);
- if (ubound)
- {
- gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- }
+ if (lower == NULL)
+ se.expr = gfc_index_one_node;
else
{
- se.expr = gfc_index_one_node;
- ubound = lower[n];
+ gcc_assert (lower[n]);
+ if (ubound)
+ {
+ gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ }
+ else
+ {
+ se.expr = gfc_index_one_node;
+ ubound = lower[n];
+ }
}
}
gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
@@ -5052,10 +5058,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set upper bound. */
gfc_init_se (&se, NULL);
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
-
+ if (expr3_desc != NULL_TREE)
+ 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_rank_cst[n], se.expr);
conv_ubound = se.expr;
@@ -5225,6 +5235,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
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
@@ -5232,7 +5269,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3)
+ tree *nelems, gfc_expr *expr3, tree e3_arr_desc)
{
tree tmp;
tree pointer;
@@ -5250,21 +5287,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable, coarray, dimension;
+ bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
/* 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
- || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
- prev_ref = ref;
- ref = ref->next;
- }
+ /* F08:C633: Array shape from expr3. */
+ ref = expr3->ref;
- if (ref == NULL || ref->type != REF_ARRAY)
- return false;
+ /* Find the last reference in the chain. */
+ if (!retrieve_last_ref (&ref, &prev_ref))
+ return false;
+ alloc_w_e3_arr_spec = true;
+ }
if (!prev_ref)
{
@@ -5300,7 +5340,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
break;
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;
upper = ref->u.ar.as->upper;
@@ -5317,7 +5358,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3);
+ expr3_elem_size, nelems, expr3, e3_arr_desc);
if (dimension)
{
@@ -7054,6 +7095,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
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)
{
/* Get a pointer to the new descriptor. */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 8544534..389a644 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -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
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *);
+ tree, tree *, gfc_expr *, tree);
/* 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 *,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 68b343b..060af8f 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -4974,7 +4974,7 @@ gfc_trans_allocate (gfc_code * code)
element size, i.e. _vptr%size, is stored in expr3_esize. Any of
the trees may be the NULL_TREE indicating that this is not
available for expr3's type. */
- tree expr3, expr3_vptr, expr3_len, expr3_esize;
+ tree expr3, expr3_vptr, expr3_len, expr3_esize, expr3_desc;
stmtblock_t block;
stmtblock_t post;
tree nelems;
@@ -4986,6 +4986,7 @@ gfc_trans_allocate (gfc_code * code)
stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+ expr3_desc = NULL_TREE;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -5040,12 +5041,13 @@ gfc_trans_allocate (gfc_code * code)
/* A array expr3 needs the scalarizer, therefore do not process it
here. */
- if (code->expr3->expr_type != EXPR_ARRAY
- && (code->expr3->rank == 0
- || code->expr3->expr_type == EXPR_FUNCTION)
- && (!code->expr3->symtree
- || !code->expr3->symtree->n.sym->as)
- && !gfc_is_class_array_ref (code->expr3, NULL))
+ if (code->ext.alloc.arr_spec_from_expr3
+ || (code->expr3->expr_type != EXPR_ARRAY
+ && (code->expr3->rank == 0
+ || code->expr3->expr_type == EXPR_FUNCTION)
+ && (!code->expr3->symtree
+ || !code->expr3->symtree->n.sym->as)
+ && !gfc_is_class_array_ref (code->expr3, NULL)))
{
/* When expr3 is a variable, i.e., a very simple expression,
then convert it once here. */
@@ -5054,17 +5056,26 @@ gfc_trans_allocate (gfc_code * code)
{
if (!code->expr3->mold
|| code->expr3->ts.type == BT_CHARACTER
- || vtab_needed)
+ || vtab_needed
+ || code->ext.alloc.arr_spec_from_expr3)
{
/* Convert expr3 to a tree. */
gfc_init_se (&se, NULL);
- se.want_pointer = 1;
- gfc_conv_expr (&se, code->expr3);
- if (!code->expr3->mold)
- expr3 = se.expr;
+ if (code->ext.alloc.arr_spec_from_expr3)
+ {
+ gfc_conv_expr_descriptor (&se, code->expr3);
+ expr3_desc = se.expr;
+ }
else
- expr3_tmp = se.expr;
- expr3_len = se.string_length;
+ {
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, code->expr3);
+ if (!code->expr3->mold)
+ expr3 = se.expr;
+ else
+ expr3_tmp = se.expr;
+ expr3_len = se.string_length;
+ }
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
}
@@ -5102,6 +5113,10 @@ gfc_trans_allocate (gfc_code * code)
expr3 = tmp;
else
expr3_tmp = tmp;
+ /* Insert this check for security reasons. A array descriptor
+ for a complicated expr3 is very unlikely. */
+ if (code->ext.alloc.arr_spec_from_expr3)
+ gcc_unreachable ();
/* When he length of a char array is easily available
here, fix it for future use. */
if (se.string_length)
@@ -5297,7 +5312,8 @@ gfc_trans_allocate (gfc_code * code)
else
tmp = expr3_esize;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems, code->expr3))
+ label_finish, tmp, &nelems,
+ code->expr3, expr3_desc))
{
/* A scalar or derived type. First compute the size to
allocate.
@@ -5501,17 +5517,25 @@ gfc_trans_allocate (gfc_code * code)
/* Initialization via SOURCE block
(or static default initializer). */
gfc_expr *rhs = gfc_copy_expr (code->expr3);
- if (expr3 != NULL_TREE
- && ((POINTER_TYPE_P (TREE_TYPE (expr3))
- && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
- || VAR_P (expr3))
+ if (((expr3 != NULL_TREE
+ && ((POINTER_TYPE_P (TREE_TYPE (expr3))
+ && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
+ || VAR_P (expr3)))
+ || expr3_desc != NULL_TREE)
&& code->expr3->ts.type == BT_CLASS
&& (expr->ts.type == BT_CLASS
|| expr->ts.type == BT_DERIVED))
{
- tree to;
+ /* copy_class_to_class can be used for class arrays, too.
+ It just needs to be ensured, that the decl_saved_descriptor
+ has a way to get to the vptr. */
+ tree to, from;
to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
- tmp = gfc_copy_class_to_class (expr3, to,
+ /* Only use the array descriptor in expr3_desc, when it is
+ set and not in a mold= expression. */
+ from = expr3_desc == NULL_TREE || code->expr3->mold ?
+ expr3 : GFC_DECL_SAVED_DESCRIPTOR (expr3_desc);
+ tmp = gfc_copy_class_to_class (from, to,
nelems, upoly_expr);
}
else if (code->expr3->ts.type == BT_CHARACTER)
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
index f7e0109..59d08d6 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
@@ -1,28 +1,110 @@
-! { dg-do compile }
+! { dg-do run }
!
! Contributed by Reinhold Bader
!
program assumed_shape_01
- use, intrinsic :: iso_c_binding
implicit none
- type, bind(c) :: cstruct
- integer(c_int) :: i
- real(c_float) :: r(2)
+ type :: cstruct
+ integer :: i
+ real :: r(2)
end type cstruct
- interface
- subroutine psub(this, that) bind(c, name='Psub')
- import :: c_float, cstruct
- real(c_float) :: this(:,:)
- type(cstruct) :: that(:)
- end subroutine psub
- end interface
-
- real(c_float) :: t(3,7)
+
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 (u(1)%i /= 4 .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) call abort()
+ deallocate (u)
-! 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" }
- call psub(t, 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
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v3] [F08] ALLOCATE with SOURCE and no array-spec
2015-04-01 13:15 ` [Patch, fortran, PR44672, v2] " Andre Vehreschild
@ 2015-04-02 9:03 ` Andre Vehreschild
2015-04-23 12:45 ` [Ping, Patch, " Andre Vehreschild
0 siblings, 1 reply; 21+ messages in thread
From: Andre Vehreschild @ 2015-04-02 9:03 UTC (permalink / raw)
To: GCC-Patches-ML, GCC-Fortran-ML, Antony Lewis, Paul Richard Thomas
[-- Attachment #1: Type: text/plain, Size: 2121 bytes --]
Hi all,
during debugging of a larger fortran source I figured that my previous patch on
44672 had still some issues, when it comes to adding a gfc_code into the chain
of codes and with a symbol. Adding a new gfc_code object before the current one
is now solved be creating a new gfc_code object, copying the current one to the
new one, initialize the old one to the new data and setting its next pointer to
the current one. Because in the gfc_code.ext.alloc a flag is introduced, that
is only set by the C-code adding a new gfc_code object, that flag can be used
to prevent doing this process endlessly. I also learned, that one has to commit
newly created symbols or one may get a very strange error in an assert in
gfc_enforce_clean_symbol_state (). After adding the gfc_commit_symbol ()
everything was fine.
Bootstraps and regtests ok on x86_64-linux-gnu/F20.
Ok for 5.2 trunk?
Regards,
Andre
On Wed, 1 Apr 2015 15:15:40 +0200
Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all,
>
> during debugging another fortran code, I figured that some cases were not yet
> met. Especially the case where a class array is in the source= or mold=
> expression. This new version of the patch fixes the issue now.
>
> Bootstraps and regtests ok on x86_64-linux-gnu/F20.
>
> Ok for 5.2 trunk?
>
> Regards,
> Andre
>
> On Mon, 30 Mar 2015 19:47:49 +0200
> Andre Vehreschild <vehre@gmx.de> wrote:
>
> > Dear all,
> >
> > please find attach a patch fixing pr44672:
> >
> > integer, dimension(:) :: arr
> > allocate(arr, source = [1,2,3])
> >
> > as for F2008:C633 now is no longer flagged, beside when you insist on
> > -std=f2003 or lower. Furthermore does the patch implement the F2008 feature
> > of obsoleting the explicit array specification on the arrays to allocate,
> > when an array valued source=/mold= expression is given.
> >
> > Bootstrap and regtests ok on x86_64-linux-gnu/F20.
> >
> > This batched is based on a trunk having my latest for pr60322 patched in
> > (else deltas may occur).
> >
> > Ok for 5.2 trunk?
> >
> > Regards,
> > Andre
>
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr44672_3.patch --]
[-- Type: text/x-patch, Size: 21379 bytes --]
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 643cd6a..9835edc 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2394,6 +2394,9 @@ typedef struct gfc_code
{
gfc_typespec ts;
gfc_alloc *list;
+ /* Take the array specification from expr3 to allocate arrays
+ without an explicit array specification. */
+ unsigned arr_spec_from_expr3:1;
}
alloc;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 316b413..21add32 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6804,7 +6804,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
have a trailing array reference that gives the size of the array. */
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 codimension;
@@ -7103,9 +7103,20 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
|| (dimension && ref2->u.ar.dimen == 0))
{
- gfc_error ("Array specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
+ /* F08:C633. */
+ if (code->expr3)
+ {
+ 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
@@ -7124,7 +7135,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
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;
switch (ar->dimen_type[i])
@@ -7201,12 +7212,23 @@ failure:
return false;
}
+
+static gfc_code *
+build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
+ gfc_component *comp1, gfc_component *comp2, locus loc);
+
+
static void
resolve_allocate_deallocate (gfc_code *code, const char *fcn)
{
gfc_expr *stat, *errmsg, *pe, *qe;
gfc_alloc *a, *p, *q;
+ /* When this flag is set already, then this allocate has already been
+ resolved. Doing so again, would result in an endless loop. */
+ if (code->ext.alloc.arr_spec_from_expr3)
+ return;
+
stat = code->expr1;
errmsg = code->expr2;
@@ -7375,8 +7397,97 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
if (strcmp (fcn, "ALLOCATE") == 0)
{
+ bool arr_alloc_wo_spec = false;
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;
+
+ if (code->expr3->expr_type == EXPR_ARRAY
+ || code->expr3->expr_type == EXPR_FUNCTION)
+ {
+ /* The trans stage can not cope with expr3->expr_type
+ being EXPR_ARRAY or EXPR_FUNCTION, therefore create a
+ temporary variable and assign expr3 to it, substituting
+ the variable in expr3. */
+ char name[25];
+ static unsigned int alloc_sym_count = 0;
+ gfc_symbol *temp_var_sym;
+ gfc_expr *temp_var;
+ gfc_code *ass, *old_alloc;
+ gfc_namespace *ns = code->ext.alloc.list->expr->symtree->n.sym->ns;
+ gfc_array_spec *as;
+ int dim;
+ mpz_t dim_size;
+
+ /* The name of the new variable. */
+ sprintf (name, "alloc_arr_init.%d", alloc_sym_count++);
+ gfc_get_symbol (name, ns, &temp_var_sym);
+ temp_var_sym->attr.artificial = 1;
+ temp_var_sym->attr.flavor = FL_VARIABLE;
+ temp_var_sym->ts = code->expr3->ts;
+ /* Build an EXPR_VARIABLE node. */
+ temp_var = gfc_get_expr ();
+ temp_var->expr_type = EXPR_VARIABLE;
+ temp_var->symtree = gfc_find_symtree (ns->sym_root, name);
+ temp_var->ts = code->expr3->ts;
+ temp_var->where = code->expr3->where;
+
+ /* Now to the most important: Set the array specification
+ correctly. */
+ as = gfc_get_array_spec ();
+ temp_var->rank = as->rank = code->expr3->rank;
+ if (code->expr3->expr_type == EXPR_ARRAY)
+ {
+ /* For EXPR_ARRAY the as can be deduced from the shape. */
+ as->type = AS_EXPLICIT;
+ for (dim = 0; dim < as->rank; ++dim)
+ {
+ gfc_array_dimen_size (code->expr3, dim, &dim_size);
+ as->lower[dim] = gfc_get_int_expr (gfc_index_integer_kind,
+ &code->expr3->where, 1);
+ as->upper[dim] = gfc_get_int_expr (gfc_index_integer_kind,
+ &code->expr3->where,
+ mpz_get_si (dim_size));
+ }
+ }
+ else if (code->expr3->expr_type == EXPR_FUNCTION)
+ {
+ /* For functions this is far more complicated. */
+ as->type = AS_DEFERRED;
+ temp_var_sym->attr.allocatable = 1;
+ }
+ else
+ gcc_unreachable ();
+
+ temp_var_sym->as = as;
+ temp_var_sym->attr.dimension = 1;
+ gfc_add_full_array_ref (temp_var, as);
+
+ ass = gfc_get_code (EXEC_ASSIGN);
+ ass->expr1 = gfc_copy_expr (temp_var);
+ ass->expr2 = code->expr3;
+ ass->loc = code->expr3->where;
+
+ gfc_resolve_code (ass, ns);
+
+ /* Now add the new code before this ones. */
+ old_alloc = gfc_get_code (EXEC_ALLOCATE);
+ *old_alloc = *code;
+ *code = *ass;
+ code->next = old_alloc;
+
+ /* Do not gfc_free_expr (temp_var), because it is inserted
+ without copy into expr3. */
+ old_alloc->expr3 = temp_var;
+ gfc_set_sym_referenced (temp_var_sym);
+ gfc_commit_symbol (temp_var_sym);
+ }
+ }
}
else
{
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0804d45..f1db69c 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4981,7 +4981,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
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)
{
tree type;
tree tmp;
@@ -5024,20 +5025,25 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set lower bound. */
gfc_init_se (&se, NULL);
- if (lower == NULL)
- se.expr = gfc_index_one_node;
+ if (expr3_desc != NULL_TREE)
+ se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, gfc_rank_cst[n]);
else
{
- gcc_assert (lower[n]);
- if (ubound)
- {
- gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- }
+ if (lower == NULL)
+ se.expr = gfc_index_one_node;
else
{
- se.expr = gfc_index_one_node;
- ubound = lower[n];
+ gcc_assert (lower[n]);
+ if (ubound)
+ {
+ gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ }
+ else
+ {
+ se.expr = gfc_index_one_node;
+ ubound = lower[n];
+ }
}
}
gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
@@ -5052,10 +5058,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set upper bound. */
gfc_init_se (&se, NULL);
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
-
+ if (expr3_desc != NULL_TREE)
+ 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_rank_cst[n], se.expr);
conv_ubound = se.expr;
@@ -5225,6 +5235,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
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
@@ -5232,7 +5269,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3)
+ tree *nelems, gfc_expr *expr3, tree e3_arr_desc)
{
tree tmp;
tree pointer;
@@ -5250,21 +5287,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable, coarray, dimension;
+ bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
/* 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
- || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
- prev_ref = ref;
- ref = ref->next;
- }
+ /* F08:C633: Array shape from expr3. */
+ ref = expr3->ref;
- if (ref == NULL || ref->type != REF_ARRAY)
- return false;
+ /* Find the last reference in the chain. */
+ if (!retrieve_last_ref (&ref, &prev_ref))
+ return false;
+ alloc_w_e3_arr_spec = true;
+ }
if (!prev_ref)
{
@@ -5300,7 +5340,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
break;
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;
upper = ref->u.ar.as->upper;
@@ -5317,7 +5358,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3);
+ expr3_elem_size, nelems, expr3, e3_arr_desc);
if (dimension)
{
@@ -7054,6 +7095,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
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)
{
/* Get a pointer to the new descriptor. */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 8544534..389a644 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -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
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *);
+ tree, tree *, gfc_expr *, tree);
/* 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 *,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 68b343b..060af8f 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -4974,7 +4974,7 @@ gfc_trans_allocate (gfc_code * code)
element size, i.e. _vptr%size, is stored in expr3_esize. Any of
the trees may be the NULL_TREE indicating that this is not
available for expr3's type. */
- tree expr3, expr3_vptr, expr3_len, expr3_esize;
+ tree expr3, expr3_vptr, expr3_len, expr3_esize, expr3_desc;
stmtblock_t block;
stmtblock_t post;
tree nelems;
@@ -4986,6 +4986,7 @@ gfc_trans_allocate (gfc_code * code)
stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+ expr3_desc = NULL_TREE;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -5040,12 +5041,13 @@ gfc_trans_allocate (gfc_code * code)
/* A array expr3 needs the scalarizer, therefore do not process it
here. */
- if (code->expr3->expr_type != EXPR_ARRAY
- && (code->expr3->rank == 0
- || code->expr3->expr_type == EXPR_FUNCTION)
- && (!code->expr3->symtree
- || !code->expr3->symtree->n.sym->as)
- && !gfc_is_class_array_ref (code->expr3, NULL))
+ if (code->ext.alloc.arr_spec_from_expr3
+ || (code->expr3->expr_type != EXPR_ARRAY
+ && (code->expr3->rank == 0
+ || code->expr3->expr_type == EXPR_FUNCTION)
+ && (!code->expr3->symtree
+ || !code->expr3->symtree->n.sym->as)
+ && !gfc_is_class_array_ref (code->expr3, NULL)))
{
/* When expr3 is a variable, i.e., a very simple expression,
then convert it once here. */
@@ -5054,17 +5056,26 @@ gfc_trans_allocate (gfc_code * code)
{
if (!code->expr3->mold
|| code->expr3->ts.type == BT_CHARACTER
- || vtab_needed)
+ || vtab_needed
+ || code->ext.alloc.arr_spec_from_expr3)
{
/* Convert expr3 to a tree. */
gfc_init_se (&se, NULL);
- se.want_pointer = 1;
- gfc_conv_expr (&se, code->expr3);
- if (!code->expr3->mold)
- expr3 = se.expr;
+ if (code->ext.alloc.arr_spec_from_expr3)
+ {
+ gfc_conv_expr_descriptor (&se, code->expr3);
+ expr3_desc = se.expr;
+ }
else
- expr3_tmp = se.expr;
- expr3_len = se.string_length;
+ {
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, code->expr3);
+ if (!code->expr3->mold)
+ expr3 = se.expr;
+ else
+ expr3_tmp = se.expr;
+ expr3_len = se.string_length;
+ }
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
}
@@ -5102,6 +5113,10 @@ gfc_trans_allocate (gfc_code * code)
expr3 = tmp;
else
expr3_tmp = tmp;
+ /* Insert this check for security reasons. A array descriptor
+ for a complicated expr3 is very unlikely. */
+ if (code->ext.alloc.arr_spec_from_expr3)
+ gcc_unreachable ();
/* When he length of a char array is easily available
here, fix it for future use. */
if (se.string_length)
@@ -5297,7 +5312,8 @@ gfc_trans_allocate (gfc_code * code)
else
tmp = expr3_esize;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems, code->expr3))
+ label_finish, tmp, &nelems,
+ code->expr3, expr3_desc))
{
/* A scalar or derived type. First compute the size to
allocate.
@@ -5501,17 +5517,25 @@ gfc_trans_allocate (gfc_code * code)
/* Initialization via SOURCE block
(or static default initializer). */
gfc_expr *rhs = gfc_copy_expr (code->expr3);
- if (expr3 != NULL_TREE
- && ((POINTER_TYPE_P (TREE_TYPE (expr3))
- && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
- || VAR_P (expr3))
+ if (((expr3 != NULL_TREE
+ && ((POINTER_TYPE_P (TREE_TYPE (expr3))
+ && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
+ || VAR_P (expr3)))
+ || expr3_desc != NULL_TREE)
&& code->expr3->ts.type == BT_CLASS
&& (expr->ts.type == BT_CLASS
|| expr->ts.type == BT_DERIVED))
{
- tree to;
+ /* copy_class_to_class can be used for class arrays, too.
+ It just needs to be ensured, that the decl_saved_descriptor
+ has a way to get to the vptr. */
+ tree to, from;
to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
- tmp = gfc_copy_class_to_class (expr3, to,
+ /* Only use the array descriptor in expr3_desc, when it is
+ set and not in a mold= expression. */
+ from = expr3_desc == NULL_TREE || code->expr3->mold ?
+ expr3 : GFC_DECL_SAVED_DESCRIPTOR (expr3_desc);
+ tmp = gfc_copy_class_to_class (from, to,
nelems, upoly_expr);
}
else if (code->expr3->ts.type == BT_CHARACTER)
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
index f7e0109..59d08d6 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
@@ -1,28 +1,110 @@
-! { dg-do compile }
+! { dg-do run }
!
! Contributed by Reinhold Bader
!
program assumed_shape_01
- use, intrinsic :: iso_c_binding
implicit none
- type, bind(c) :: cstruct
- integer(c_int) :: i
- real(c_float) :: r(2)
+ type :: cstruct
+ integer :: i
+ real :: r(2)
end type cstruct
- interface
- subroutine psub(this, that) bind(c, name='Psub')
- import :: c_float, cstruct
- real(c_float) :: this(:,:)
- type(cstruct) :: that(:)
- end subroutine psub
- end interface
-
- real(c_float) :: t(3,7)
+
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 (u(1)%i /= 4 .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) call abort()
+ deallocate (u)
-! 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" }
- call psub(t, 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
[-- Attachment #3: pr44672_3.clog --]
[-- Type: application/octet-stream, Size: 1362 bytes --]
gcc/testsuite/ChangeLog:
2015-04-02 Andre Vehreschild <vehre@gmx.de>
* gfortran.dg/allocate_with_source_3.f90: Enhanced to
check implementation of F2008:C633.
gcc/fortran/ChangeLog:
2015-04-02 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. Generate temporay variable assignment to
allow source-expressions without explicit array
specification.
* trans-array.c (gfc_array_init_size): Get lower and
upper bound from a tree array descriptor.
(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-stmt.c (gfc_trans_allocate): Get expr3 array
descriptor for temporary arrays to allow allocate(array,
source = array_expression) for array without array
specification.
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Ping, Patch, fortran, PR44672, v3] [F08] ALLOCATE with SOURCE and no array-spec
2015-04-02 9:03 ` [Patch, fortran, PR44672, v3] " Andre Vehreschild
@ 2015-04-23 12:45 ` Andre Vehreschild
2015-04-29 15:29 ` [Patch, fortran, PR44672, v4] " Andre Vehreschild
0 siblings, 1 reply; 21+ messages in thread
From: Andre Vehreschild @ 2015-04-23 12:45 UTC (permalink / raw)
To: GCC-Patches-ML, GCC-Fortran-ML, Antony Lewis, Paul Richard Thomas
Ping !
On Thu, 2 Apr 2015 11:03:30 +0200
Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all,
>
> during debugging of a larger fortran source I figured that my previous patch
> on 44672 had still some issues, when it comes to adding a gfc_code into the
> chain of codes and with a symbol. Adding a new gfc_code object before the
> current one is now solved be creating a new gfc_code object, copying the
> current one to the new one, initialize the old one to the new data and
> setting its next pointer to the current one. Because in the
> gfc_code.ext.alloc a flag is introduced, that is only set by the C-code
> adding a new gfc_code object, that flag can be used to prevent doing this
> process endlessly. I also learned, that one has to commit newly created
> symbols or one may get a very strange error in an assert in
> gfc_enforce_clean_symbol_state (). After adding the gfc_commit_symbol ()
> everything was fine.
>
> Bootstraps and regtests ok on x86_64-linux-gnu/F20.
>
> Ok for 5.2 trunk?
>
> Regards,
> Andre
>
> On Wed, 1 Apr 2015 15:15:40 +0200
> Andre Vehreschild <vehre@gmx.de> wrote:
>
> > Hi all,
> >
> > during debugging another fortran code, I figured that some cases were not
> > yet met. Especially the case where a class array is in the source= or mold=
> > expression. This new version of the patch fixes the issue now.
> >
> > Bootstraps and regtests ok on x86_64-linux-gnu/F20.
> >
> > Ok for 5.2 trunk?
> >
> > Regards,
> > Andre
> >
> > On Mon, 30 Mar 2015 19:47:49 +0200
> > Andre Vehreschild <vehre@gmx.de> wrote:
> >
> > > Dear all,
> > >
> > > please find attach a patch fixing pr44672:
> > >
> > > integer, dimension(:) :: arr
> > > allocate(arr, source = [1,2,3])
> > >
> > > as for F2008:C633 now is no longer flagged, beside when you insist on
> > > -std=f2003 or lower. Furthermore does the patch implement the F2008
> > > feature of obsoleting the explicit array specification on the arrays to
> > > allocate, when an array valued source=/mold= expression is given.
> > >
> > > Bootstrap and regtests ok on x86_64-linux-gnu/F20.
> > >
> > > This batched is based on a trunk having my latest for pr60322 patched in
> > > (else deltas may occur).
> > >
> > > Ok for 5.2 trunk?
> > >
> > > Regards,
> > > Andre
> >
> >
>
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v4] [F08] ALLOCATE with SOURCE and no array-spec
2015-04-23 12:45 ` [Ping, Patch, " Andre Vehreschild
@ 2015-04-29 15:29 ` Andre Vehreschild
2015-04-30 14:31 ` [Patch, fortran, PR44672, v5] " Andre Vehreschild
0 siblings, 1 reply; 21+ messages in thread
From: Andre Vehreschild @ 2015-04-29 15:29 UTC (permalink / raw)
To: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 1241 bytes --]
Hi all,
this is the fourth version of the patch, adapting to the current state of
trunk. This patch is based on my patch for 65584 version 2 and needs that patch
applied beforehand to apply cleanly. The patch for 65548 is available from:
https://gcc.gnu.org/ml/fortran/2015-04/msg00121.html
Scope:
Allow allocate of arrays w/o having to give an array-spec as specified in
F2008:C633. An example is:
integer, dimension(:) :: arr
allocate(arr, source = [1,2,3])
Solution:
While resolving an allocate, the objects to allocate are analyzed whether they
carry an array-spec, if not the array-spec of the source=-expression is
transferred. Unfortunately some source=-expressions are not easy to handle and
have to be assigned to a temporary variable first. Only with the temporary
variable the gfc_trans_allocate() is then able to compute the array descriptor
correctly and allocate with correct array bounds.
Side notes:
This patch creates a regression in alloc_comp_constructor_1.f90 where two
free()'s are gone missing. This will be fixed by the patch for pr58586 and
therefore not repeated here.
Bootstraps and regtests ok on x86_64-linux-gnu/f21.
Ok for trunk?
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr44672_4.clog --]
[-- Type: application/octet-stream, Size: 1490 bytes --]
gcc/testsuite/ChangeLog:
2015-04-29 Andre Vehreschild <vehre@gmx.de>
* gfortran.dg/allocate_with_source_3.f90: Enhanced to
check implementation of F2008:C633.
gcc/fortran/ChangeLog:
2015-04-29 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. Generate temporay variable assignment to
allow source-expressions without explicit array
specification.
* trans-array.c (gfc_array_init_size): Get lower and
upper bound from a tree array descriptor.
(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): Prevent array
constructors for allocatable components to generate
deallocate code.
* 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.
[-- Attachment #3: pr44672_4.patch --]
[-- Type: text/x-patch, Size: 22022 bytes --]
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 832a6ce..9b5f4cf 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2394,6 +2394,9 @@ typedef struct gfc_code
{
gfc_typespec ts;
gfc_alloc *list;
+ /* Take the array specification from expr3 to allocate arrays
+ without an explicit array specification. */
+ unsigned arr_spec_from_expr3:1;
}
alloc;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 316b413..41b128a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6804,7 +6804,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
have a trailing array reference that gives the size of the array. */
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 codimension;
@@ -7103,13 +7103,24 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
|| (dimension && ref2->u.ar.dimen == 0))
{
- gfc_error ("Array specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
+ /* F08:C633. */
+ if (code->expr3)
+ {
+ 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
- context of an ALLOCATE specification. */
+ context of an ALLOCATE specification. */
ar = &ref2->u.ar;
@@ -7124,7 +7135,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
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;
switch (ar->dimen_type[i])
@@ -7201,12 +7212,18 @@ failure:
return false;
}
+
static void
resolve_allocate_deallocate (gfc_code *code, const char *fcn)
{
gfc_expr *stat, *errmsg, *pe, *qe;
gfc_alloc *a, *p, *q;
+ /* When this flag is set already, then this allocate has already been
+ resolved. Doing so again, would result in an endless loop. */
+ if (code->ext.alloc.arr_spec_from_expr3)
+ return;
+
stat = code->expr1;
errmsg = code->expr2;
@@ -7375,8 +7392,96 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
if (strcmp (fcn, "ALLOCATE") == 0)
{
+ bool arr_alloc_wo_spec = false;
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;
+
+ if (code->expr3->expr_type == EXPR_ARRAY
+ || code->expr3->expr_type == EXPR_FUNCTION)
+ {
+ /* The trans stage can not cope with expr3->expr_type
+ being EXPR_ARRAY or EXPR_FUNCTION, therefore create a
+ temporary variable and assign expr3 to it, substituting
+ the variable in expr3. */
+ char name[25];
+ static unsigned int alloc_sym_count = 0;
+ gfc_symbol *temp_var_sym;
+ gfc_expr *temp_var;
+ gfc_code *ass, *old_alloc;
+ gfc_namespace *ns = code->ext.alloc.list->expr->symtree->n.sym->ns;
+ gfc_array_spec *as;
+ int dim;
+ mpz_t dim_size;
+
+ /* The name of the new variable. */
+ sprintf (name, "alloc_arr_init.%d", alloc_sym_count++);
+ gfc_get_symbol (name, ns, &temp_var_sym);
+ temp_var_sym->attr.artificial = 1;
+ temp_var_sym->attr.flavor = FL_VARIABLE;
+ temp_var_sym->ts = code->expr3->ts;
+ /* Build an EXPR_VARIABLE node. */
+ temp_var = gfc_get_expr ();
+ temp_var->expr_type = EXPR_VARIABLE;
+ temp_var->symtree = gfc_find_symtree (ns->sym_root, name);
+ temp_var->ts = code->expr3->ts;
+ temp_var->where = code->expr3->where;
+
+ /* Now to the most important: Set the array specification
+ correctly. */
+ as = gfc_get_array_spec ();
+ temp_var->rank = as->rank = code->expr3->rank;
+ if (code->expr3->expr_type == EXPR_ARRAY)
+ {
+ /* For EXPR_ARRAY the as can be deduced from the shape. */
+ as->type = AS_EXPLICIT;
+ for (dim = 0; dim < as->rank; ++dim)
+ {
+ gfc_array_dimen_size (code->expr3, dim, &dim_size);
+ as->lower[dim] = gfc_get_int_expr (gfc_index_integer_kind,
+ &code->expr3->where, 1);
+ as->upper[dim] = gfc_get_int_expr (gfc_index_integer_kind,
+ &code->expr3->where,
+ mpz_get_si (dim_size));
+ }
+ }
+ else if (code->expr3->expr_type == EXPR_FUNCTION)
+ {
+ /* For functions this is far more complicated. */
+ as->type = AS_DEFERRED;
+ temp_var_sym->attr.allocatable = 1;
+ }
+ else
+ gcc_unreachable ();
+
+ temp_var_sym->as = as;
+ temp_var_sym->attr.dimension = 1;
+ gfc_add_full_array_ref (temp_var, as);
+
+ ass = gfc_get_code (EXEC_ASSIGN);
+ ass->expr1 = gfc_copy_expr (temp_var);
+ ass->expr2 = code->expr3;
+ ass->loc = code->expr3->where;
+
+ gfc_resolve_code (ass, ns);
+ /* Now add the new code before this ones. */
+ old_alloc = gfc_get_code (EXEC_ALLOCATE);
+ *old_alloc = *code;
+ *code = *ass;
+ code->next = old_alloc;
+
+ /* Do not gfc_free_expr (temp_var), because it is inserted
+ without copy into expr3. */
+ old_alloc->expr3 = temp_var;
+ gfc_set_sym_referenced (temp_var_sym);
+ gfc_commit_symbol (temp_var_sym);
+ }
+ }
}
else
{
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index a17f431..08c8861 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4982,7 +4982,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
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)
{
tree type;
tree tmp;
@@ -5025,20 +5026,25 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set lower bound. */
gfc_init_se (&se, NULL);
- if (lower == NULL)
- se.expr = gfc_index_one_node;
+ if (expr3_desc != NULL_TREE)
+ se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, gfc_rank_cst[n]);
else
{
- gcc_assert (lower[n]);
- if (ubound)
- {
- gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- }
+ if (lower == NULL)
+ se.expr = gfc_index_one_node;
else
{
- se.expr = gfc_index_one_node;
- ubound = lower[n];
+ gcc_assert (lower[n]);
+ if (ubound)
+ {
+ gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ }
+ else
+ {
+ se.expr = gfc_index_one_node;
+ ubound = lower[n];
+ }
}
}
gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
@@ -5053,10 +5059,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set upper bound. */
gfc_init_se (&se, NULL);
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
-
+ if (expr3_desc != NULL_TREE)
+ 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_rank_cst[n], se.expr);
conv_ubound = se.expr;
@@ -5226,6 +5236,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
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
@@ -5233,7 +5270,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3)
+ tree *nelems, gfc_expr *expr3, tree e3_arr_desc)
{
tree tmp;
tree pointer;
@@ -5251,21 +5288,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable, coarray, dimension;
+ bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
/* 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
- || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
- prev_ref = ref;
- ref = ref->next;
- }
+ /* F08:C633: Array shape from expr3. */
+ ref = expr3->ref;
- if (ref == NULL || ref->type != REF_ARRAY)
- return false;
+ /* Find the last reference in the chain. */
+ if (!retrieve_last_ref (&ref, &prev_ref))
+ return false;
+ alloc_w_e3_arr_spec = true;
+ }
if (!prev_ref)
{
@@ -5301,7 +5341,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
break;
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;
upper = ref->u.ar.as->upper;
@@ -5318,7 +5359,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
&se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3);
+ expr3_elem_size, nelems, expr3, e3_arr_desc);
if (dimension)
{
@@ -7057,6 +7098,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
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)
{
/* Get a pointer to the new descriptor. */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 76bad2a..2132f84 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -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
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *);
+ tree, tree *, gfc_expr *, tree);
/* 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 *,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9c5ce7d..19869c3 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5340,7 +5340,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
&& e->ts.u.derived->attr.alloc_comp
&& !(e->symtree && e->symtree->n.sym->attr.pointer)
- && (e->expr_type != EXPR_VARIABLE && !e->rank))
+ && e->expr_type != EXPR_VARIABLE && !e->rank
+ && e->expr_type != EXPR_STRUCTURE)
{
int parm_rank;
tmp = build_fold_indirect_ref_loc (input_location,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 1e435be..dcad9bc 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5104,7 +5104,7 @@ gfc_trans_allocate (gfc_code * code)
element size, i.e. _vptr%size, is stored in expr3_esize. Any of
the trees may be the NULL_TREE indicating that this is not
available for expr3's type. */
- tree expr3, expr3_vptr, expr3_len, expr3_esize;
+ tree expr3, expr3_vptr, expr3_len, expr3_esize, expr3_desc;
stmtblock_t block;
stmtblock_t post;
tree nelems;
@@ -5116,6 +5116,7 @@ gfc_trans_allocate (gfc_code * code)
stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+ expr3_desc = NULL_TREE;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -5173,21 +5174,30 @@ gfc_trans_allocate (gfc_code * code)
{
if (!code->expr3->mold
|| code->expr3->ts.type == BT_CHARACTER
- || vtab_needed)
+ || vtab_needed
+ || code->ext.alloc.arr_spec_from_expr3)
{
/* Convert expr3 to a tree. */
gfc_init_se (&se, NULL);
- /* For all "simple" expression just get the descriptor or the
- reference, respectively, depending on the rank of the expr. */
- if (code->expr3->rank != 0)
- gfc_conv_expr_descriptor (&se, code->expr3);
- else
- gfc_conv_expr_reference (&se, code->expr3);
- if (!code->expr3->mold)
- expr3 = se.expr;
+ if (code->ext.alloc.arr_spec_from_expr3)
+ {
+ gfc_conv_expr_descriptor (&se, code->expr3);
+ expr3_desc = se.expr;
+ }
else
- expr3_tmp = se.expr;
- expr3_len = se.string_length;
+ {
+ /* For all "simple" expression just get the descriptor or the
+ reference, respectively, depending on the rank of the expr. */
+ if (code->expr3->rank != 0)
+ gfc_conv_expr_descriptor (&se, code->expr3);
+ else
+ gfc_conv_expr_reference (&se, code->expr3);
+ if (!code->expr3->mold)
+ expr3 = se.expr;
+ else
+ expr3_tmp = se.expr;
+ expr3_len = se.string_length;
+ }
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
}
@@ -5228,7 +5238,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
/* Prevent aliasing, i.e., se.expr may be already a
- variable declaration. */
+ variable declaration. */
if (!VAR_P (se.expr))
{
tmp = build_fold_indirect_ref_loc (input_location,
@@ -5241,6 +5251,10 @@ gfc_trans_allocate (gfc_code * code)
expr3 = tmp;
else
expr3_tmp = tmp;
+ /* Insert this check for security reasons. A array descriptor
+ for a complicated expr3 is very unlikely. */
+ if (code->ext.alloc.arr_spec_from_expr3)
+ gcc_unreachable ();
/* When he length of a char array is easily available
here, fix it for future use. */
if (se.string_length)
@@ -5439,7 +5453,8 @@ gfc_trans_allocate (gfc_code * code)
else
tmp = expr3_esize;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems, code->expr3))
+ label_finish, tmp, &nelems,
+ code->expr3, expr3_desc))
{
/* A scalar or derived type. First compute the size to
allocate.
@@ -5643,17 +5658,26 @@ gfc_trans_allocate (gfc_code * code)
/* Initialization via SOURCE block
(or static default initializer). */
gfc_expr *rhs = gfc_copy_expr (code->expr3);
- if (expr3 != NULL_TREE
- && ((POINTER_TYPE_P (TREE_TYPE (expr3))
- && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
- || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))))
+ if ((expr3_desc != NULL_TREE
+ || (expr3 != NULL_TREE
+ && ((POINTER_TYPE_P (TREE_TYPE (expr3))
+ && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
+ || (VAR_P (expr3) && GFC_CLASS_TYPE_P (
+ TREE_TYPE (expr3))))))
&& code->expr3->ts.type == BT_CLASS
&& (expr->ts.type == BT_CLASS
|| expr->ts.type == BT_DERIVED))
{
- tree to;
+ /* copy_class_to_class can be used for class arrays, too.
+ It just needs to be ensured, that the decl_saved_descriptor
+ has a way to get to the vptr. */
+ tree to, from;
to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
- tmp = gfc_copy_class_to_class (expr3, to,
+ /* Only use the array descriptor in expr3_desc, when it is
+ set and not in a mold= expression. */
+ from = expr3_desc == NULL_TREE || code->expr3->mold ?
+ expr3 : GFC_DECL_SAVED_DESCRIPTOR (expr3_desc);
+ tmp = gfc_copy_class_to_class (from, to,
nelems, upoly_expr);
}
else if (code->expr3->ts.type == BT_CHARACTER)
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
index f7e0109..59d08d6 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
@@ -1,28 +1,110 @@
-! { dg-do compile }
+! { dg-do run }
!
! Contributed by Reinhold Bader
!
program assumed_shape_01
- use, intrinsic :: iso_c_binding
implicit none
- type, bind(c) :: cstruct
- integer(c_int) :: i
- real(c_float) :: r(2)
+ type :: cstruct
+ integer :: i
+ real :: r(2)
end type cstruct
- interface
- subroutine psub(this, that) bind(c, name='Psub')
- import :: c_float, cstruct
- real(c_float) :: this(:,:)
- type(cstruct) :: that(:)
- end subroutine psub
- end interface
-
- real(c_float) :: t(3,7)
+
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 (u(1)%i /= 4 .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) call abort()
+ deallocate (u)
-! 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" }
- call psub(t, 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
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v5] [F08] ALLOCATE with SOURCE and no array-spec
2015-04-29 15:29 ` [Patch, fortran, PR44672, v4] " Andre Vehreschild
@ 2015-04-30 14:31 ` Andre Vehreschild
2015-05-19 10:29 ` [Patch, fortran, PR44672, v6] " Andre Vehreschild
0 siblings, 1 reply; 21+ messages in thread
From: Andre Vehreschild @ 2015-04-30 14:31 UTC (permalink / raw)
To: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 2480 bytes --]
Hi all,
and also for this bug, I like to present an updated patch. It was brought to my
attention, that the previous patch did not fix statements like:
allocate(m, source=[(I, I=1, n)])
where n is a variable and
type p
class(*), allocatable :: m(:,:)
end type
real mat(2,3)
type(P) :: o
allocate(o%m, source=mat)
The new version of the patch fixes those issue now also and furthermore
addresses some issues (most probably not all) where the rank of the
source=-variable and the rank of the array to allocate differ. For example,
when one is do:
real v(:)
allocate(v, source= arr(1,2:3))
where arr has a rank of 2 and only the source=-expression a rank of one, which
is then compatible with v. Nevertheless did this need addressing, when setting
up the descriptor of the v and during data copy.
Bootstrap ok on x86_64-linux-gnu/f21.
Regtests with one regression in gfortran.dg/alloc_comp_constructor_1.f90, which
is addressed in the patch for pr58586, whose final version is in preparation.
Ok for trunk in combination with 58586 once both are reviewed?
Regards,
Andre
On Wed, 29 Apr 2015 17:23:58 +0200
Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all,
>
> this is the fourth version of the patch, adapting to the current state of
> trunk. This patch is based on my patch for 65584 version 2 and needs that
> patch applied beforehand to apply cleanly. The patch for 65548 is available
> from:
>
> https://gcc.gnu.org/ml/fortran/2015-04/msg00121.html
>
> Scope:
>
> Allow allocate of arrays w/o having to give an array-spec as specified in
> F2008:C633. An example is:
>
> integer, dimension(:) :: arr
> allocate(arr, source = [1,2,3])
>
> Solution:
>
> While resolving an allocate, the objects to allocate are analyzed whether they
> carry an array-spec, if not the array-spec of the source=-expression is
> transferred. Unfortunately some source=-expressions are not easy to handle and
> have to be assigned to a temporary variable first. Only with the temporary
> variable the gfc_trans_allocate() is then able to compute the array descriptor
> correctly and allocate with correct array bounds.
>
> Side notes:
>
> This patch creates a regression in alloc_comp_constructor_1.f90 where two
> free()'s are gone missing. This will be fixed by the patch for pr58586 and
> therefore not repeated here.
>
> Bootstraps and regtests ok on x86_64-linux-gnu/f21.
>
> Ok for trunk?
>
> Regards,
> Andre
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr44672_5.clog --]
[-- Type: application/octet-stream, Size: 1597 bytes --]
gcc/testsuite/ChangeLog:
2015-04-30 Andre Vehreschild <vehre@gmx.de>
PR fortran/44672
PR fortran/45440
PR fortran/57307
* gfortran.dg/allocate_with_source_3.f90: Enhanced to
check implementation of F2008:C633.
* gfortran.dg/allocate_with_source_6.f08: New test.
gcc/fortran/ChangeLog:
2015-04-30 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. Generate temporay variable assignment to
allow source-expressions without explicit array
specification.
* trans-array.c (gfc_array_init_size): Get lower and
upper bound from a tree array descriptor.
(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): Prevent array
constructors for allocatable components to generate
deallocate code.
* 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.
[-- Attachment #3: pr44672_5.patch --]
[-- Type: text/x-patch, Size: 28718 bytes --]
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 832a6ce..9b5f4cf 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2394,6 +2394,9 @@ typedef struct gfc_code
{
gfc_typespec ts;
gfc_alloc *list;
+ /* Take the array specification from expr3 to allocate arrays
+ without an explicit array specification. */
+ unsigned arr_spec_from_expr3:1;
}
alloc;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 316b413..41026af 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6804,7 +6804,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
have a trailing array reference that gives the size of the array. */
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 codimension;
@@ -7103,13 +7103,24 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
|| (dimension && ref2->u.ar.dimen == 0))
{
- gfc_error ("Array specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
+ /* F08:C633. */
+ if (code->expr3)
+ {
+ 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
- context of an ALLOCATE specification. */
+ context of an ALLOCATE specification. */
ar = &ref2->u.ar;
@@ -7124,7 +7135,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
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;
switch (ar->dimen_type[i])
@@ -7201,12 +7212,18 @@ failure:
return false;
}
+
static void
resolve_allocate_deallocate (gfc_code *code, const char *fcn)
{
gfc_expr *stat, *errmsg, *pe, *qe;
gfc_alloc *a, *p, *q;
+ /* When this flag is set already, then this allocate has already been
+ resolved. Doing so again, would result in an endless loop. */
+ if (code->ext.alloc.arr_spec_from_expr3)
+ return;
+
stat = code->expr1;
errmsg = code->expr2;
@@ -7375,8 +7392,108 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
if (strcmp (fcn, "ALLOCATE") == 0)
{
+ bool arr_alloc_wo_spec = false;
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;
+
+ if (code->expr3->expr_type == EXPR_ARRAY
+ || code->expr3->expr_type == EXPR_FUNCTION)
+ {
+ /* The trans stage can not cope with expr3->expr_type
+ being EXPR_ARRAY or EXPR_FUNCTION, therefore create a
+ temporary variable and assign expr3 to it, substituting
+ the variable in expr3. */
+ char name[25];
+ static unsigned int alloc_sym_count = 0;
+ gfc_symbol *temp_var_sym;
+ gfc_expr *temp_var;
+ gfc_code *ass, *old_alloc;
+ gfc_namespace *ns = code->ext.alloc.list->expr->symtree->n.sym->ns;
+ gfc_array_spec *as;
+ int dim;
+ mpz_t dim_size;
+
+ /* The name of the new variable. */
+ sprintf (name, "alloc_arr_init.%d", alloc_sym_count++);
+ gfc_get_symbol (name, ns, &temp_var_sym);
+ temp_var_sym->attr.artificial = 1;
+ temp_var_sym->attr.flavor = FL_VARIABLE;
+ temp_var_sym->ts = code->expr3->ts;
+ /* Build an EXPR_VARIABLE node. */
+ temp_var = gfc_get_expr ();
+ temp_var->expr_type = EXPR_VARIABLE;
+ temp_var->symtree = gfc_find_symtree (ns->sym_root, name);
+ temp_var->ts = code->expr3->ts;
+ temp_var->where = code->expr3->where;
+
+ /* Now to the most important: Set the array specification
+ correctly. */
+ as = gfc_get_array_spec ();
+ temp_var->rank = as->rank = code->expr3->rank;
+ if (code->expr3->expr_type == EXPR_ARRAY)
+ {
+ /* For EXPR_ARRAY the as can be deduced from the shape. */
+ as->type = AS_EXPLICIT;
+ for (dim = 0; dim < as->rank; ++dim)
+ {
+ if (!gfc_array_dimen_size (code->expr3, dim, &dim_size))
+ {
+ /* When the array dimensions can not be determined at
+ compile time, use a deferred type array. */
+ as->type = AS_DEFERRED;
+ while (dim >= 0)
+ {
+ as->lower[dim] = as->upper[dim] = NULL;
+ --dim;
+ }
+ temp_var_sym->attr.allocatable = 1;
+ break;
+ }
+ as->lower[dim] = gfc_get_int_expr (gfc_index_integer_kind,
+ &code->expr3->where, 1);
+ as->upper[dim] = gfc_get_int_expr (gfc_index_integer_kind,
+ &code->expr3->where,
+ mpz_get_si (dim_size));
+ }
+ }
+ else if (code->expr3->expr_type == EXPR_FUNCTION)
+ {
+ /* For functions this is far more complicated. */
+ as->type = AS_DEFERRED;
+ temp_var_sym->attr.allocatable = 1;
+ }
+ else
+ gcc_unreachable ();
+
+ temp_var_sym->as = as;
+ temp_var_sym->attr.dimension = 1;
+ gfc_add_full_array_ref (temp_var, as);
+
+ ass = gfc_get_code (EXEC_ASSIGN);
+ ass->expr1 = gfc_copy_expr (temp_var);
+ ass->expr2 = code->expr3;
+ ass->loc = code->expr3->where;
+
+ gfc_resolve_code (ass, ns);
+ /* Now add the new code before this ones. */
+ old_alloc = gfc_get_code (EXEC_ALLOCATE);
+ *old_alloc = *code;
+ *code = *ass;
+ code->next = old_alloc;
+
+ /* Do not gfc_free_expr (temp_var), because it is inserted
+ without copy into expr3. */
+ old_alloc->expr3 = temp_var;
+ gfc_set_sym_referenced (temp_var_sym);
+ gfc_commit_symbol (temp_var_sym);
+ }
+ }
}
else
{
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index a17f431..8c0c90e 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4982,7 +4982,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
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)
{
tree type;
tree tmp;
@@ -4997,7 +4998,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tree var;
stmtblock_t thenblock;
stmtblock_t elseblock;
- gfc_expr *ubound;
+ gfc_expr *ubound = NULL;
gfc_se se;
int n;
@@ -5012,6 +5013,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
or_expr = boolean_false_node;
+ /* When expr3_desc is set, use its rank, because we want to allocate an
+ array with the array_spec coming from source=. */
+ if (expr3_desc != NULL_TREE)
+ rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (expr3_desc));
+
for (n = 0; n < rank; n++)
{
tree conv_lbound;
@@ -5021,24 +5027,29 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
lower == NULL => lbound = 1, ubound = upper[n]
upper[n] = NULL => lbound = 1, ubound = lower[n]
upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
- ubound = upper[n];
/* Set lower bound. */
gfc_init_se (&se, NULL);
- if (lower == NULL)
- se.expr = gfc_index_one_node;
+ if (expr3_desc != NULL_TREE)
+ se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, gfc_rank_cst[n]);
else
{
- gcc_assert (lower[n]);
- if (ubound)
- {
- gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- }
+ ubound = upper[n];
+ if (lower == NULL)
+ se.expr = gfc_index_one_node;
else
{
- se.expr = gfc_index_one_node;
- ubound = lower[n];
+ gcc_assert (lower[n]);
+ if (ubound)
+ {
+ gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ }
+ else
+ {
+ se.expr = gfc_index_one_node;
+ ubound = lower[n];
+ }
}
}
gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
@@ -5053,10 +5064,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set upper bound. */
gfc_init_se (&se, NULL);
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
-
+ if (expr3_desc != NULL_TREE)
+ 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_rank_cst[n], se.expr);
conv_ubound = se.expr;
@@ -5226,6 +5241,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
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
@@ -5233,7 +5275,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3)
+ tree *nelems, gfc_expr *expr3, tree e3_arr_desc)
{
tree tmp;
tree pointer;
@@ -5251,21 +5293,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable, coarray, dimension;
+ bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
/* 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
- || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
- prev_ref = ref;
- ref = ref->next;
- }
+ /* F08:C633: Array shape from expr3. */
+ ref = expr3->ref;
- if (ref == NULL || ref->type != REF_ARRAY)
- return false;
+ /* Find the last reference in the chain. */
+ if (!retrieve_last_ref (&ref, &prev_ref))
+ return false;
+ alloc_w_e3_arr_spec = true;
+ }
if (!prev_ref)
{
@@ -5301,7 +5346,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
break;
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;
upper = ref->u.ar.as->upper;
@@ -5315,10 +5361,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
overflow = integer_zero_node;
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,
&se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3);
+ expr3_elem_size, nelems, expr3, e3_arr_desc);
if (dimension)
{
@@ -7057,6 +7104,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
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)
{
/* Get a pointer to the new descriptor. */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 76bad2a..2132f84 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -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
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *);
+ tree, tree *, gfc_expr *, tree);
/* 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 *,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9c5ce7d..19869c3 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5340,7 +5340,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
&& e->ts.u.derived->attr.alloc_comp
&& !(e->symtree && e->symtree->n.sym->attr.pointer)
- && (e->expr_type != EXPR_VARIABLE && !e->rank))
+ && e->expr_type != EXPR_VARIABLE && !e->rank
+ && e->expr_type != EXPR_STRUCTURE)
{
int parm_rank;
tmp = build_fold_indirect_ref_loc (input_location,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 1e435be..9cbb6aa 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5104,7 +5104,7 @@ gfc_trans_allocate (gfc_code * code)
element size, i.e. _vptr%size, is stored in expr3_esize. Any of
the trees may be the NULL_TREE indicating that this is not
available for expr3's type. */
- tree expr3, expr3_vptr, expr3_len, expr3_esize;
+ tree expr3, expr3_vptr, expr3_len, expr3_esize, expr3_desc;
stmtblock_t block;
stmtblock_t post;
tree nelems;
@@ -5116,6 +5116,7 @@ gfc_trans_allocate (gfc_code * code)
stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+ expr3_desc = NULL_TREE;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -5173,21 +5174,30 @@ gfc_trans_allocate (gfc_code * code)
{
if (!code->expr3->mold
|| code->expr3->ts.type == BT_CHARACTER
- || vtab_needed)
+ || vtab_needed
+ || code->ext.alloc.arr_spec_from_expr3)
{
/* Convert expr3 to a tree. */
gfc_init_se (&se, NULL);
- /* For all "simple" expression just get the descriptor or the
- reference, respectively, depending on the rank of the expr. */
- if (code->expr3->rank != 0)
- gfc_conv_expr_descriptor (&se, code->expr3);
- else
- gfc_conv_expr_reference (&se, code->expr3);
- if (!code->expr3->mold)
- expr3 = se.expr;
+ if (code->ext.alloc.arr_spec_from_expr3)
+ {
+ gfc_conv_expr_descriptor (&se, code->expr3);
+ expr3_desc = se.expr;
+ }
else
- expr3_tmp = se.expr;
- expr3_len = se.string_length;
+ {
+ /* For all "simple" expression just get the descriptor or the
+ reference, respectively, depending on the rank of the expr. */
+ if (code->expr3->rank != 0)
+ gfc_conv_expr_descriptor (&se, code->expr3);
+ else
+ gfc_conv_expr_reference (&se, code->expr3);
+ if (!code->expr3->mold)
+ expr3 = se.expr;
+ else
+ expr3_tmp = se.expr;
+ expr3_len = se.string_length;
+ }
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
}
@@ -5228,7 +5238,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
/* Prevent aliasing, i.e., se.expr may be already a
- variable declaration. */
+ variable declaration. */
if (!VAR_P (se.expr))
{
tmp = build_fold_indirect_ref_loc (input_location,
@@ -5241,6 +5251,10 @@ gfc_trans_allocate (gfc_code * code)
expr3 = tmp;
else
expr3_tmp = tmp;
+ /* Insert this check for security reasons. A array descriptor
+ for a complicated expr3 is very unlikely. */
+ if (code->ext.alloc.arr_spec_from_expr3)
+ gcc_unreachable ();
/* When he length of a char array is easily available
here, fix it for future use. */
if (se.string_length)
@@ -5439,7 +5453,8 @@ gfc_trans_allocate (gfc_code * code)
else
tmp = expr3_esize;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems, code->expr3))
+ label_finish, tmp, &nelems,
+ code->expr3, expr3_desc))
{
/* A scalar or derived type. First compute the size to
allocate.
@@ -5643,17 +5658,26 @@ gfc_trans_allocate (gfc_code * code)
/* Initialization via SOURCE block
(or static default initializer). */
gfc_expr *rhs = gfc_copy_expr (code->expr3);
- if (expr3 != NULL_TREE
- && ((POINTER_TYPE_P (TREE_TYPE (expr3))
- && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
- || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))))
+ if ((expr3_desc != NULL_TREE
+ || (expr3 != NULL_TREE
+ && ((POINTER_TYPE_P (TREE_TYPE (expr3))
+ && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
+ || (VAR_P (expr3) && GFC_CLASS_TYPE_P (
+ TREE_TYPE (expr3))))))
&& code->expr3->ts.type == BT_CLASS
&& (expr->ts.type == BT_CLASS
|| expr->ts.type == BT_DERIVED))
{
- tree to;
+ /* copy_class_to_class can be used for class arrays, too.
+ It just needs to be ensured, that the decl_saved_descriptor
+ has a way to get to the vptr. */
+ tree to, from;
to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
- tmp = gfc_copy_class_to_class (expr3, to,
+ /* Only use the array descriptor in expr3_desc, when it is
+ set and not in a mold= expression. */
+ from = expr3_desc == NULL_TREE || code->expr3->mold ?
+ expr3 : GFC_DECL_SAVED_DESCRIPTOR (expr3_desc);
+ tmp = gfc_copy_class_to_class (from, to,
nelems, upoly_expr);
}
else if (code->expr3->ts.type == BT_CHARACTER)
@@ -5731,29 +5755,73 @@ gfc_trans_allocate (gfc_code * code)
if (dataref && dataref->u.c.component->as)
{
- int dim;
+ int dim = 0;
gfc_expr *temp;
gfc_ref *ref = dataref->next;
ref->u.ar.type = AR_SECTION;
- /* We have to set up the array reference to give ranges
- in all dimensions and ensure that the end and stride
- are set so that the copy can be scalarized. */
- dim = 0;
- for (; dim < dataref->u.c.component->as->rank; dim++)
+ if (code->ext.alloc.arr_spec_from_expr3)
+ {
+ /* Take the array dimensions from the
+ source=-expression. */
+ gfc_array_ref *source_ref =
+ gfc_find_array_ref (code->expr3);
+ if (source_ref->type == AR_FULL)
+ {
+ /* For full array refs copy the bounds. */
+ for (; dim < dataref->u.c.component->as->rank; dim++)
+ {
+ ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+ ref->u.ar.start[dim] =
+ gfc_copy_expr (source_ref->as->lower[dim]);
+ ref->u.ar.end[dim] =
+ gfc_copy_expr (source_ref->as->upper[dim]);
+ }
+ }
+ else
+ {
+ int sdim = 0;
+ /* For partial array refs, the partials. */
+ for (; dim < dataref->u.c.component->as->rank;
+ dim++, sdim++)
+ {
+ ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+ ref->u.ar.start[dim] =
+ gfc_get_int_expr (gfc_default_integer_kind,
+ &al->expr->where, 1);
+ /* Skip over element dimensions. */
+ while (source_ref->dimen_type[sdim] == DIMEN_ELEMENT)
+ ++sdim;
+ temp = gfc_subtract (gfc_copy_expr (
+ source_ref->end[sdim]),
+ gfc_copy_expr (
+ source_ref->start[sdim]));
+ ref->u.ar.end[dim] = gfc_add (temp,
+ gfc_get_int_expr (gfc_default_integer_kind,
+ &al->expr->where, 1));
+ }
+ }
+ }
+ else
{
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- if (ref->u.ar.end[dim] == NULL)
+ /* We have to set up the array reference to give ranges
+ in all dimensions and ensure that the end and stride
+ are set so that the copy can be scalarized. */
+ for (; dim < dataref->u.c.component->as->rank; dim++)
{
- ref->u.ar.end[dim] = ref->u.ar.start[dim];
- temp = gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1);
- ref->u.ar.start[dim] = temp;
+ ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+ if (ref->u.ar.end[dim] == NULL)
+ {
+ ref->u.ar.end[dim] = ref->u.ar.start[dim];
+ temp = gfc_get_int_expr (gfc_default_integer_kind,
+ &al->expr->where, 1);
+ ref->u.ar.start[dim] = temp;
+ }
+ temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
+ gfc_copy_expr (ref->u.ar.start[dim]));
+ temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
+ &al->expr->where, 1),
+ temp);
}
- temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
- gfc_copy_expr (ref->u.ar.start[dim]));
- temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1),
- temp);
}
}
if (rhs->ts.type == BT_CLASS)
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
index f7e0109..59d08d6 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
@@ -1,28 +1,110 @@
-! { dg-do compile }
+! { dg-do run }
!
! Contributed by Reinhold Bader
!
program assumed_shape_01
- use, intrinsic :: iso_c_binding
implicit none
- type, bind(c) :: cstruct
- integer(c_int) :: i
- real(c_float) :: r(2)
+ type :: cstruct
+ integer :: i
+ real :: r(2)
end type cstruct
- interface
- subroutine psub(this, that) bind(c, name='Psub')
- import :: c_float, cstruct
- real(c_float) :: this(:,:)
- type(cstruct) :: that(:)
- end subroutine psub
- end interface
-
- real(c_float) :: t(3,7)
+
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 (u(1)%i /= 4 .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) call abort()
+ deallocate (u)
-! 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" }
- call psub(t, 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
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08
new file mode 100644
index 0000000..86df531
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08
@@ -0,0 +1,79 @@
+! { 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
+
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec
2015-04-30 14:31 ` [Patch, fortran, PR44672, v5] " Andre Vehreschild
@ 2015-05-19 10:29 ` Andre Vehreschild
2015-05-22 10:24 ` Ping: " Andre Vehreschild
2015-05-25 19:35 ` Mikael Morin
0 siblings, 2 replies; 21+ messages in thread
From: Andre Vehreschild @ 2015-05-19 10:29 UTC (permalink / raw)
To: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 3023 bytes --]
Hi all,
update based on latest 65548 (v5) patch and current trunk. Description and
issue addressed unchanged (see cite below).
Bootstrapped and regtested on x86_64-linux-gnu/f21.
Any volunteers to review? The initial version dates back to March 30. 2015. Not
a single comment so far!
- Andre
On Thu, 30 Apr 2015 16:17:42 +0200
Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all,
>
> and also for this bug, I like to present an updated patch. It was brought to
> my attention, that the previous patch did not fix statements like:
>
> allocate(m, source=[(I, I=1, n)])
>
> where n is a variable and
>
> type p
> class(*), allocatable :: m(:,:)
> end type
> real mat(2,3)
> type(P) :: o
> allocate(o%m, source=mat)
>
> The new version of the patch fixes those issue now also and furthermore
> addresses some issues (most probably not all) where the rank of the
> source=-variable and the rank of the array to allocate differ. For example,
> when one is do:
>
> real v(:)
> allocate(v, source= arr(1,2:3))
>
> where arr has a rank of 2 and only the source=-expression a rank of one, which
> is then compatible with v. Nevertheless did this need addressing, when setting
> up the descriptor of the v and during data copy.
>
> Bootstrap ok on x86_64-linux-gnu/f21.
> Regtests with one regression in gfortran.dg/alloc_comp_constructor_1.f90,
> which is addressed in the patch for pr58586, whose final version is in
> preparation.
>
> Ok for trunk in combination with 58586 once both are reviewed?
>
> Regards,
> Andre
>
>
> On Wed, 29 Apr 2015 17:23:58 +0200
> Andre Vehreschild <vehre@gmx.de> wrote:
>
> > Hi all,
> >
> > this is the fourth version of the patch, adapting to the current state of
> > trunk. This patch is based on my patch for 65584 version 2 and needs that
> > patch applied beforehand to apply cleanly. The patch for 65548 is available
> > from:
> >
> > https://gcc.gnu.org/ml/fortran/2015-04/msg00121.html
> >
> > Scope:
> >
> > Allow allocate of arrays w/o having to give an array-spec as specified in
> > F2008:C633. An example is:
> >
> > integer, dimension(:) :: arr
> > allocate(arr, source = [1,2,3])
> >
> > Solution:
> >
> > While resolving an allocate, the objects to allocate are analyzed whether
> > they carry an array-spec, if not the array-spec of the source=-expression is
> > transferred. Unfortunately some source=-expressions are not easy to handle
> > and have to be assigned to a temporary variable first. Only with the
> > temporary variable the gfc_trans_allocate() is then able to compute the
> > array descriptor correctly and allocate with correct array bounds.
> >
> > Side notes:
> >
> > This patch creates a regression in alloc_comp_constructor_1.f90 where two
> > free()'s are gone missing. This will be fixed by the patch for pr58586 and
> > therefore not repeated here.
> >
> > Bootstraps and regtests ok on x86_64-linux-gnu/f21.
> >
> > Ok for trunk?
> >
> > Regards,
> > Andre
> >
>
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr44672_6.clog --]
[-- Type: application/octet-stream, Size: 1597 bytes --]
gcc/testsuite/ChangeLog:
2015-05-19 Andre Vehreschild <vehre@gmx.de>
PR fortran/44672
PR fortran/45440
PR fortran/57307
* gfortran.dg/allocate_with_source_3.f90: Enhanced to
check implementation of F2008:C633.
* gfortran.dg/allocate_with_source_6.f08: New test.
gcc/fortran/ChangeLog:
2015-05-19 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. Generate temporay variable assignment to
allow source-expressions without explicit array
specification.
* trans-array.c (gfc_array_init_size): Get lower and
upper bound from a tree array descriptor.
(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): Prevent array
constructors for allocatable components to generate
deallocate code.
* 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.
[-- Attachment #3: pr44672_6.patch --]
[-- Type: text/x-patch, Size: 28734 bytes --]
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index aaa4e89..a7d862b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2396,6 +2396,9 @@ typedef struct gfc_code
{
gfc_typespec ts;
gfc_alloc *list;
+ /* Take the array specification from expr3 to allocate arrays
+ without an explicit array specification. */
+ unsigned arr_spec_from_expr3:1;
}
alloc;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index fbf260f..6678138 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6804,7 +6804,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
have a trailing array reference that gives the size of the array. */
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 codimension;
@@ -7103,13 +7103,24 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
|| (dimension && ref2->u.ar.dimen == 0))
{
- gfc_error ("Array specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
+ /* F08:C633. */
+ if (code->expr3)
+ {
+ 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
- context of an ALLOCATE specification. */
+ context of an ALLOCATE specification. */
ar = &ref2->u.ar;
@@ -7124,7 +7135,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
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;
switch (ar->dimen_type[i])
@@ -7201,12 +7212,18 @@ failure:
return false;
}
+
static void
resolve_allocate_deallocate (gfc_code *code, const char *fcn)
{
gfc_expr *stat, *errmsg, *pe, *qe;
gfc_alloc *a, *p, *q;
+ /* When this flag is set already, then this allocate has already been
+ resolved. Doing so again, would result in an endless loop. */
+ if (code->ext.alloc.arr_spec_from_expr3)
+ return;
+
stat = code->expr1;
errmsg = code->expr2;
@@ -7375,8 +7392,109 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
if (strcmp (fcn, "ALLOCATE") == 0)
{
+ bool arr_alloc_wo_spec = false;
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;
+
+ if (code->expr3->expr_type == EXPR_ARRAY
+ || code->expr3->expr_type == EXPR_FUNCTION)
+ {
+ /* The trans stage can not cope with expr3->expr_type
+ being EXPR_ARRAY or EXPR_FUNCTION, therefore create a
+ temporary variable and assign expr3 to it, substituting
+ the variable in expr3. */
+ char name[25];
+ static unsigned int alloc_sym_count = 0;
+ gfc_symbol *temp_var_sym;
+ gfc_expr *temp_var;
+ gfc_code *ass, *old_alloc;
+ gfc_namespace *ns =
+ code->ext.alloc.list->expr->symtree->n.sym->ns;
+ gfc_array_spec *as;
+ int dim;
+ mpz_t dim_size;
+
+ /* The name of the new variable. */
+ sprintf (name, "alloc_arr_init.%d", alloc_sym_count++);
+ gfc_get_symbol (name, ns, &temp_var_sym);
+ temp_var_sym->attr.artificial = 1;
+ temp_var_sym->attr.flavor = FL_VARIABLE;
+ temp_var_sym->ts = code->expr3->ts;
+ /* Build an EXPR_VARIABLE node. */
+ temp_var = gfc_get_expr ();
+ temp_var->expr_type = EXPR_VARIABLE;
+ temp_var->symtree = gfc_find_symtree (ns->sym_root, name);
+ temp_var->ts = code->expr3->ts;
+ temp_var->where = code->expr3->where;
+
+ /* Now to the most important: Set the array specification
+ correctly. */
+ as = gfc_get_array_spec ();
+ temp_var->rank = as->rank = code->expr3->rank;
+ if (code->expr3->expr_type == EXPR_ARRAY)
+ {
+ /* For EXPR_ARRAY the as can be deduced from the shape. */
+ as->type = AS_EXPLICIT;
+ for (dim = 0; dim < as->rank; ++dim)
+ {
+ if (!gfc_array_dimen_size (code->expr3, dim, &dim_size))
+ {
+ /* When the array dimensions can not be determined at
+ compile time, use a deferred type array. */
+ as->type = AS_DEFERRED;
+ while (dim >= 0)
+ {
+ as->lower[dim] = as->upper[dim] = NULL;
+ --dim;
+ }
+ temp_var_sym->attr.allocatable = 1;
+ break;
+ }
+ as->lower[dim] = gfc_get_int_expr (gfc_index_integer_kind,
+ &code->expr3->where, 1);
+ as->upper[dim] = gfc_get_int_expr (gfc_index_integer_kind,
+ &code->expr3->where,
+ mpz_get_si (dim_size));
+ }
+ }
+ else if (code->expr3->expr_type == EXPR_FUNCTION)
+ {
+ /* For functions this is far more complicated. */
+ as->type = AS_DEFERRED;
+ temp_var_sym->attr.allocatable = 1;
+ }
+ else
+ gcc_unreachable ();
+
+ temp_var_sym->as = as;
+ temp_var_sym->attr.dimension = 1;
+ gfc_add_full_array_ref (temp_var, as);
+
+ ass = gfc_get_code (EXEC_ASSIGN);
+ ass->expr1 = gfc_copy_expr (temp_var);
+ ass->expr2 = code->expr3;
+ ass->loc = code->expr3->where;
+
+ gfc_resolve_code (ass, ns);
+ /* Now add the new code before this ones. */
+ old_alloc = gfc_get_code (EXEC_ALLOCATE);
+ *old_alloc = *code;
+ *code = *ass;
+ code->next = old_alloc;
+
+ /* Do not gfc_free_expr (temp_var), because it is inserted
+ without copy into expr3. */
+ old_alloc->expr3 = temp_var;
+ gfc_set_sym_referenced (temp_var_sym);
+ gfc_commit_symbol (temp_var_sym);
+ }
+ }
}
else
{
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 8267f6a..2e9582d 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5009,7 +5009,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
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)
{
tree type;
tree tmp;
@@ -5024,7 +5025,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tree var;
stmtblock_t thenblock;
stmtblock_t elseblock;
- gfc_expr *ubound;
+ gfc_expr *ubound = NULL;
gfc_se se;
int n;
@@ -5039,6 +5040,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
or_expr = boolean_false_node;
+ /* When expr3_desc is set, use its rank, because we want to allocate an
+ array with the array_spec coming from source=. */
+ if (expr3_desc != NULL_TREE)
+ rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (expr3_desc));
+
for (n = 0; n < rank; n++)
{
tree conv_lbound;
@@ -5048,24 +5054,29 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
lower == NULL => lbound = 1, ubound = upper[n]
upper[n] = NULL => lbound = 1, ubound = lower[n]
upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
- ubound = upper[n];
/* Set lower bound. */
gfc_init_se (&se, NULL);
- if (lower == NULL)
- se.expr = gfc_index_one_node;
+ if (expr3_desc != NULL_TREE)
+ se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, gfc_rank_cst[n]);
else
{
- gcc_assert (lower[n]);
- if (ubound)
- {
- gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- }
+ ubound = upper[n];
+ if (lower == NULL)
+ se.expr = gfc_index_one_node;
else
{
- se.expr = gfc_index_one_node;
- ubound = lower[n];
+ gcc_assert (lower[n]);
+ if (ubound)
+ {
+ gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ }
+ else
+ {
+ se.expr = gfc_index_one_node;
+ ubound = lower[n];
+ }
}
}
gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
@@ -5080,10 +5091,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set upper bound. */
gfc_init_se (&se, NULL);
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
-
+ if (expr3_desc != NULL_TREE)
+ 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_rank_cst[n], se.expr);
conv_ubound = se.expr;
@@ -5253,6 +5268,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
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
@@ -5260,7 +5302,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3)
+ tree *nelems, gfc_expr *expr3, tree e3_arr_desc)
{
tree tmp;
tree pointer;
@@ -5278,21 +5320,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable, coarray, dimension;
+ bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
/* 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
- || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
- prev_ref = ref;
- ref = ref->next;
- }
+ /* F08:C633: Array shape from expr3. */
+ ref = expr3->ref;
- if (ref == NULL || ref->type != REF_ARRAY)
- return false;
+ /* Find the last reference in the chain. */
+ if (!retrieve_last_ref (&ref, &prev_ref))
+ return false;
+ alloc_w_e3_arr_spec = true;
+ }
if (!prev_ref)
{
@@ -5328,7 +5373,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
break;
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;
upper = ref->u.ar.as->upper;
@@ -5342,10 +5388,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
overflow = integer_zero_node;
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,
&se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3);
+ expr3_elem_size, nelems, expr3, e3_arr_desc);
if (dimension)
{
@@ -7084,6 +7131,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
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)
{
/* Get a pointer to the new descriptor. */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 2155b58..6e5378f 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -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
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *);
+ tree, tree *, gfc_expr *, tree);
/* 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 *,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9be8a42..b02b255 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5328,7 +5328,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
&& e->ts.u.derived->attr.alloc_comp
&& !(e->symtree && e->symtree->n.sym->attr.pointer)
- && (e->expr_type != EXPR_VARIABLE && !e->rank))
+ && e->expr_type != EXPR_VARIABLE && !e->rank
+ && e->expr_type != EXPR_STRUCTURE)
{
int parm_rank;
tmp = build_fold_indirect_ref_loc (input_location,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 6d565ae..3528626 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5104,7 +5104,7 @@ gfc_trans_allocate (gfc_code * code)
element size, i.e. _vptr%size, is stored in expr3_esize. Any of
the trees may be the NULL_TREE indicating that this is not
available for expr3's type. */
- tree expr3, expr3_vptr, expr3_len, expr3_esize;
+ tree expr3, expr3_vptr, expr3_len, expr3_esize, expr3_desc;
stmtblock_t block;
stmtblock_t post;
tree nelems;
@@ -5117,6 +5117,7 @@ gfc_trans_allocate (gfc_code * code)
stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+ expr3_desc = NULL_TREE;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -5174,21 +5175,31 @@ gfc_trans_allocate (gfc_code * code)
{
if (!code->expr3->mold
|| code->expr3->ts.type == BT_CHARACTER
- || vtab_needed)
+ || vtab_needed
+ || code->ext.alloc.arr_spec_from_expr3)
{
/* Convert expr3 to a tree. */
gfc_init_se (&se, NULL);
- /* For all "simple" expression just get the descriptor or the
- reference, respectively, depending on the rank of the expr. */
- if (code->expr3->rank != 0)
- gfc_conv_expr_descriptor (&se, code->expr3);
- else
- gfc_conv_expr_reference (&se, code->expr3);
- if (!code->expr3->mold)
- expr3 = se.expr;
+ if (code->ext.alloc.arr_spec_from_expr3)
+ {
+ gfc_conv_expr_descriptor (&se, code->expr3);
+ expr3_desc = se.expr;
+ }
else
- expr3_tmp = se.expr;
- expr3_len = se.string_length;
+ {
+ /* For all "simple" expression just get the descriptor
+ or the reference, respectively, depending on the
+ rank of the expr. */
+ if (code->expr3->rank != 0)
+ gfc_conv_expr_descriptor (&se, code->expr3);
+ else
+ gfc_conv_expr_reference (&se, code->expr3);
+ if (!code->expr3->mold)
+ expr3 = se.expr;
+ else
+ expr3_tmp = se.expr;
+ expr3_len = se.string_length;
+ }
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
}
@@ -5215,7 +5226,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
/* Prevent aliasing, i.e., se.expr may be already a
- variable declaration. */
+ variable declaration. */
if (!VAR_P (se.expr))
{
tree var;
@@ -5233,6 +5244,10 @@ gfc_trans_allocate (gfc_code * code)
expr3 = tmp;
else
expr3_tmp = tmp;
+ /* Insert this check for security reasons. A array descriptor
+ for a complicated expr3 is very unlikely. */
+ if (code->ext.alloc.arr_spec_from_expr3)
+ gcc_unreachable ();
/* When he length of a char array is easily available
here, fix it for future use. */
if (se.string_length)
@@ -5487,7 +5502,8 @@ gfc_trans_allocate (gfc_code * code)
else
tmp = expr3_esize;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems, code->expr3))
+ label_finish, tmp, &nelems,
+ code->expr3, expr3_desc))
{
/* A scalar or derived type. First compute the size to
allocate.
@@ -5690,17 +5706,26 @@ gfc_trans_allocate (gfc_code * code)
{
/* Initialization via SOURCE block (or static default initializer).
Classes need some special handling, so catch them first. */
- if (expr3 != NULL_TREE
- && ((POINTER_TYPE_P (TREE_TYPE (expr3))
- && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
- || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))))
+ if ((expr3_desc != NULL_TREE
+ || (expr3 != NULL_TREE
+ && ((POINTER_TYPE_P (TREE_TYPE (expr3))
+ && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
+ || (VAR_P (expr3) && GFC_CLASS_TYPE_P (
+ TREE_TYPE (expr3))))))
&& code->expr3->ts.type == BT_CLASS
&& (expr->ts.type == BT_CLASS
|| expr->ts.type == BT_DERIVED))
{
- tree to;
+ /* copy_class_to_class can be used for class arrays, too.
+ It just needs to be ensured, that the decl_saved_descriptor
+ has a way to get to the vptr. */
+ tree to, from;
to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
- tmp = gfc_copy_class_to_class (expr3, to,
+ /* Only use the array descriptor in expr3_desc, when it is
+ set and not in a mold= expression. */
+ from = expr3_desc == NULL_TREE || code->expr3->mold ?
+ expr3 : GFC_DECL_SAVED_DESCRIPTOR (expr3_desc);
+ tmp = gfc_copy_class_to_class (from, to,
nelems, upoly_expr);
}
else if (al->expr->ts.type == BT_CLASS)
@@ -5731,29 +5756,77 @@ gfc_trans_allocate (gfc_code * code)
if (dataref && dataref->u.c.component->as)
{
- int dim;
+ int dim = 0;
gfc_expr *temp;
gfc_ref *ref = dataref->next;
ref->u.ar.type = AR_SECTION;
- /* We have to set up the array reference to give ranges
- in all dimensions and ensure that the end and stride
- are set so that the copy can be scalarized. */
- dim = 0;
- for (; dim < dataref->u.c.component->as->rank; dim++)
+ if (code->ext.alloc.arr_spec_from_expr3)
+ {
+ /* Take the array dimensions from the
+ source=-expression. */
+ gfc_array_ref *source_ref =
+ gfc_find_array_ref (code->expr3);
+ if (source_ref->type == AR_FULL)
+ {
+ /* For full array refs copy the bounds. */
+ for (; dim < dataref->u.c.component->as->rank; dim++)
+ {
+ ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+ ref->u.ar.start[dim] =
+ gfc_copy_expr (source_ref->as->lower[dim]);
+ ref->u.ar.end[dim] =
+ gfc_copy_expr (source_ref->as->upper[dim]);
+ }
+ }
+ else
+ {
+ int sdim = 0;
+ /* For partial array refs, the partials. */
+ for (; dim < dataref->u.c.component->as->rank;
+ dim++, sdim++)
+ {
+ ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+ ref->u.ar.start[dim] =
+ gfc_get_int_expr (gfc_default_integer_kind,
+ &al->expr->where, 1);
+ /* Skip over element dimensions. */
+ while (source_ref->dimen_type[sdim]
+ == DIMEN_ELEMENT)
+ ++sdim;
+ temp = gfc_subtract (gfc_copy_expr (
+ source_ref->end[sdim]),
+ gfc_copy_expr (
+ source_ref->start[sdim]));
+ ref->u.ar.end[dim] = gfc_add (temp,
+ gfc_get_int_expr (gfc_default_integer_kind,
+ &al->expr->where, 1));
+ }
+ }
+ }
+ else
{
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- if (ref->u.ar.end[dim] == NULL)
+ /* We have to set up the array reference to give ranges
+ in all dimensions and ensure that the end and stride
+ are set so that the copy can be scalarized. */
+ for (; dim < dataref->u.c.component->as->rank; dim++)
{
- ref->u.ar.end[dim] = ref->u.ar.start[dim];
- temp = gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1);
- ref->u.ar.start[dim] = temp;
+ ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+ if (ref->u.ar.end[dim] == NULL)
+ {
+ ref->u.ar.end[dim] = ref->u.ar.start[dim];
+ temp = gfc_get_int_expr (gfc_default_integer_kind,
+ &al->expr->where, 1);
+ ref->u.ar.start[dim] = temp;
+ }
+ temp = gfc_subtract (gfc_copy_expr (
+ ref->u.ar.end[dim]),
+ gfc_copy_expr (
+ ref->u.ar.start[dim]));
+ temp = gfc_add (gfc_get_int_expr (
+ gfc_default_integer_kind,
+ &al->expr->where, 1),
+ temp);
}
- temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
- gfc_copy_expr (ref->u.ar.start[dim]));
- temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1),
- temp);
}
}
if (rhs->ts.type == BT_CLASS)
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
index f7e0109..59d08d6 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
@@ -1,28 +1,110 @@
-! { dg-do compile }
+! { dg-do run }
!
! Contributed by Reinhold Bader
!
program assumed_shape_01
- use, intrinsic :: iso_c_binding
implicit none
- type, bind(c) :: cstruct
- integer(c_int) :: i
- real(c_float) :: r(2)
+ type :: cstruct
+ integer :: i
+ real :: r(2)
end type cstruct
- interface
- subroutine psub(this, that) bind(c, name='Psub')
- import :: c_float, cstruct
- real(c_float) :: this(:,:)
- type(cstruct) :: that(:)
- end subroutine psub
- end interface
-
- real(c_float) :: t(3,7)
+
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 (u(1)%i /= 4 .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) call abort()
+ deallocate (u)
-! 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" }
- call psub(t, 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
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08
new file mode 100644
index 0000000..86df531
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08
@@ -0,0 +1,79 @@
+! { 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
+
^ permalink raw reply [flat|nested] 21+ messages in thread
* Ping: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec
2015-05-19 10:29 ` [Patch, fortran, PR44672, v6] " Andre Vehreschild
@ 2015-05-22 10:24 ` Andre Vehreschild
2015-05-25 19:35 ` Mikael Morin
1 sibling, 0 replies; 21+ messages in thread
From: Andre Vehreschild @ 2015-05-22 10:24 UTC (permalink / raw)
To: GCC-Patches-ML, GCC-Fortran-ML
Hi,
the patch (65548) this one depends on is in trunk now.
Still bootstraps ok and regtests with the issue in
gfortran.dg/alloc_comp_constructor_1.f90 (which is addressed by the patch for
pr58586 already) on x86_64-linux-gnu/f21.
Ok for trunk?
- Andre
On Tue, 19 May 2015 12:26:02 +0200
Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all,
>
> update based on latest 65548 (v5) patch and current trunk. Description and
> issue addressed unchanged (see cite below).
>
> Bootstrapped and regtested on x86_64-linux-gnu/f21.
>
> Any volunteers to review? The initial version dates back to March 30. 2015.
> Not a single comment so far!
>
> - Andre
>
>
>
> On Thu, 30 Apr 2015 16:17:42 +0200
> Andre Vehreschild <vehre@gmx.de> wrote:
>
> > Hi all,
> >
> > and also for this bug, I like to present an updated patch. It was brought to
> > my attention, that the previous patch did not fix statements like:
> >
> > allocate(m, source=[(I, I=1, n)])
> >
> > where n is a variable and
> >
> > type p
> > class(*), allocatable :: m(:,:)
> > end type
> > real mat(2,3)
> > type(P) :: o
> > allocate(o%m, source=mat)
> >
> > The new version of the patch fixes those issue now also and furthermore
> > addresses some issues (most probably not all) where the rank of the
> > source=-variable and the rank of the array to allocate differ. For example,
> > when one is do:
> >
> > real v(:)
> > allocate(v, source= arr(1,2:3))
> >
> > where arr has a rank of 2 and only the source=-expression a rank of one,
> > which is then compatible with v. Nevertheless did this need addressing,
> > when setting up the descriptor of the v and during data copy.
> >
> > Bootstrap ok on x86_64-linux-gnu/f21.
> > Regtests with one regression in gfortran.dg/alloc_comp_constructor_1.f90,
> > which is addressed in the patch for pr58586, whose final version is in
> > preparation.
> >
> > Ok for trunk in combination with 58586 once both are reviewed?
> >
> > Regards,
> > Andre
> >
> >
> > On Wed, 29 Apr 2015 17:23:58 +0200
> > Andre Vehreschild <vehre@gmx.de> wrote:
> >
> > > Hi all,
> > >
> > > this is the fourth version of the patch, adapting to the current state of
> > > trunk. This patch is based on my patch for 65584 version 2 and needs that
> > > patch applied beforehand to apply cleanly. The patch for 65548 is
> > > available from:
> > >
> > > https://gcc.gnu.org/ml/fortran/2015-04/msg00121.html
> > >
> > > Scope:
> > >
> > > Allow allocate of arrays w/o having to give an array-spec as specified in
> > > F2008:C633. An example is:
> > >
> > > integer, dimension(:) :: arr
> > > allocate(arr, source = [1,2,3])
> > >
> > > Solution:
> > >
> > > While resolving an allocate, the objects to allocate are analyzed whether
> > > they carry an array-spec, if not the array-spec of the source=-expression
> > > is transferred. Unfortunately some source=-expressions are not easy to
> > > handle and have to be assigned to a temporary variable first. Only with
> > > the temporary variable the gfc_trans_allocate() is then able to compute
> > > the array descriptor correctly and allocate with correct array bounds.
> > >
> > > Side notes:
> > >
> > > This patch creates a regression in alloc_comp_constructor_1.f90 where two
> > > free()'s are gone missing. This will be fixed by the patch for pr58586 and
> > > therefore not repeated here.
> > >
> > > Bootstraps and regtests ok on x86_64-linux-gnu/f21.
> > >
> > > Ok for trunk?
> > >
> > > Regards,
> > > Andre
> > >
> >
> >
>
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec
2015-05-19 10:29 ` [Patch, fortran, PR44672, v6] " Andre Vehreschild
2015-05-22 10:24 ` Ping: " Andre Vehreschild
@ 2015-05-25 19:35 ` Mikael Morin
2015-05-28 15:48 ` Andre Vehreschild
1 sibling, 1 reply; 21+ messages in thread
From: Mikael Morin @ 2015-05-25 19:35 UTC (permalink / raw)
To: Andre Vehreschild, GCC-Patches-ML, GCC-Fortran-ML
Le 19/05/2015 12:26, Andre Vehreschild a écrit :
> Hi all,
>
> update based on latest 65548 (v5) patch and current trunk. Description and
> issue addressed unchanged (see cite below).
>
> Bootstrapped and regtested on x86_64-linux-gnu/f21.
>
> Any volunteers to review? The initial version dates back to March 30. 2015. Not
> a single comment so far!
>
Let's start now. ;-)
I don't understand why one of your previous patches was factoring the
source expression evaluation to a temporary in gfc_trans_allocate, and
now with this patch you do the same thing in gfc_resolve_allocate, not
reusing the part in gfc_trans_allocate.
> *************** failure:
> *** 7201,7212 ****
> --- 7212,7229 ----
> return false;
> }
>
> +
> static void
> resolve_allocate_deallocate (gfc_code *code, const char *fcn)
> {
> gfc_expr *stat, *errmsg, *pe, *qe;
> gfc_alloc *a, *p, *q;
>
> + /* When this flag is set already, then this allocate has already been
> + resolved. Doing so again, would result in an endless loop. */
> + if (code->ext.alloc.arr_spec_from_expr3)
> + return;
> +
I expect you'll miss some error messages by doing this.
Where is the endless loop?
> *************** resolve_allocate_deallocate (gfc_code *c
> *** 7375,7382 ****
> --- 7392,7500 ----
>
> if (strcmp (fcn, "ALLOCATE") == 0)
> {
> + bool arr_alloc_wo_spec = false;
> for (a = code->ext.alloc.list; a; a = a->next)
> ! resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
> !
> ! if (arr_alloc_wo_spec && code->expr3)
> ! {
[...]
> !
> ! ass = gfc_get_code (EXEC_ASSIGN);
This memory is not freed as far as I know.
I think you can use a local variable for it.
*** /tmp/PRaWHc_trans-expr.c 2015-05-25 19:54:35.056309429 +0200
--- /tmp/7e82nd_trans-expr.c 2015-05-25 19:54:35.058309429 +0200
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 5328,5334 ****
if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
&& e->ts.u.derived->attr.alloc_comp
&& !(e->symtree && e->symtree->n.sym->attr.pointer)
! && (e->expr_type != EXPR_VARIABLE && !e->rank))
{
int parm_rank;
tmp = build_fold_indirect_ref_loc (input_location,
--- 5328,5335 ----
if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
&& e->ts.u.derived->attr.alloc_comp
&& !(e->symtree && e->symtree->n.sym->attr.pointer)
! && e->expr_type != EXPR_VARIABLE && !e->rank
! && e->expr_type != EXPR_STRUCTURE)
{
int parm_rank;
tmp = build_fold_indirect_ref_loc (input_location,
Can't you remove this? It's undone by the PR58586 patch.
> *************** gfc_trans_allocate (gfc_code * code)
> *** 5733,5746 ****
>
> if (dataref && dataref->u.c.component->as)
> {
> ! int dim;
> gfc_expr *temp;
> gfc_ref *ref = dataref->next;
> ref->u.ar.type = AR_SECTION;
> /* We have to set up the array reference to give ranges
> in all dimensions and ensure that the end and stride
> are set so that the copy can be scalarized. */
> - dim = 0;
> for (; dim < dataref->u.c.component->as->rank; dim++)
> {
> ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
> --- 5758,5815 ----
>
> if (dataref && dataref->u.c.component->as)
> {
> ! int dim = 0;
> gfc_expr *temp;
> gfc_ref *ref = dataref->next;
> ref->u.ar.type = AR_SECTION;
> + if (code->ext.alloc.arr_spec_from_expr3)
> + {
> + /* Take the array dimensions from the
> + source=-expression. */
> + gfc_array_ref *source_ref =
> + gfc_find_array_ref (code->expr3);
Does this work? code->expr3 is not always a variable.
> + if (source_ref->type == AR_FULL)
> + {
> + /* For full array refs copy the bounds. */
> + for (; dim < dataref->u.c.component->as->rank; dim++)
> + {
> + ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
> + ref->u.ar.start[dim] =
> + gfc_copy_expr (source_ref->as->lower[dim]);
> + ref->u.ar.end[dim] =
> + gfc_copy_expr (source_ref->as->upper[dim]);
> + }
This won't work. Consider this:
block
integer :: a(n)
n = n+1
allocate(b, source=a)
end block
You have to use a full array ref. In fact you can use a full array ref
everywhere, I think.
That's all for now.
Mikael
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec
2015-05-25 19:35 ` Mikael Morin
@ 2015-05-28 15:48 ` Andre Vehreschild
2015-05-28 18:42 ` Mikael Morin
0 siblings, 1 reply; 21+ messages in thread
From: Andre Vehreschild @ 2015-05-28 15:48 UTC (permalink / raw)
To: Mikael Morin; +Cc: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 5276 bytes --]
Hi Mikael,
thanks for the comments so far.
> I don't understand why one of your previous patches was factoring the
> source expression evaluation to a temporary in gfc_trans_allocate, and
> now with this patch you do the same thing in gfc_resolve_allocate, not
> reusing the part in gfc_trans_allocate.
When I remember correctly, then at the time of writing this patch the one
factoring out the temporary in gfc_trans_allocate() was not doing that yet. At
least it was not doing it always as needed. Therefore we are looking at a kind
of history here already.
>
> > *************** failure:
> > *** 7201,7212 ****
> > --- 7212,7229 ----
> > return false;
> > }
> >
> > +
> > static void
> > resolve_allocate_deallocate (gfc_code *code, const char *fcn)
> > {
> > gfc_expr *stat, *errmsg, *pe, *qe;
> > gfc_alloc *a, *p, *q;
> >
> > + /* When this flag is set already, then this allocate has already been
> > + resolved. Doing so again, would result in an endless loop. */
> > + if (code->ext.alloc.arr_spec_from_expr3)
> > + return;
> > +
> I expect you'll miss some error messages by doing this.
> Where is the endless loop?
This has been removed. The endless loop was triggered by gfc_resolve_code () in
line 179 of the patch, which is now in chunk that is mostly removed.
> > *************** resolve_allocate_deallocate (gfc_code *c
> > *** 7375,7382 ****
> > --- 7392,7500 ----
> >
> > if (strcmp (fcn, "ALLOCATE") == 0)
> > {
> > + bool arr_alloc_wo_spec = false;
> > for (a = code->ext.alloc.list; a; a = a->next)
> > ! resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
> > !
> > ! if (arr_alloc_wo_spec && code->expr3)
> > ! {
> [...]
> > !
> > ! ass = gfc_get_code (EXEC_ASSIGN);
> This memory is not freed as far as I know.
> I think you can use a local variable for it.
Complete block removed. Therefore fixed.
> *** /tmp/PRaWHc_trans-expr.c 2015-05-25 19:54:35.056309429 +0200
> --- /tmp/7e82nd_trans-expr.c 2015-05-25 19:54:35.058309429 +0200
> *************** gfc_conv_procedure_call (gfc_se * se, gf
> *** 5328,5334 ****
> if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
> && e->ts.u.derived->attr.alloc_comp
> && !(e->symtree && e->symtree->n.sym->attr.pointer)
> ! && (e->expr_type != EXPR_VARIABLE && !e->rank))
> {
> int parm_rank;
> tmp = build_fold_indirect_ref_loc (input_location,
> --- 5328,5335 ----
> if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
> && e->ts.u.derived->attr.alloc_comp
> && !(e->symtree && e->symtree->n.sym->attr.pointer)
> ! && e->expr_type != EXPR_VARIABLE && !e->rank
> ! && e->expr_type != EXPR_STRUCTURE)
> {
> int parm_rank;
> tmp = build_fold_indirect_ref_loc (input_location,
>
> Can't you remove this? It's undone by the PR58586 patch.
Removed, looks like an artefact of a long forgotten need.
> > *************** gfc_trans_allocate (gfc_code * code)
> > *** 5733,5746 ****
> >
> > if (dataref && dataref->u.c.component->as)
> > {
> > ! int dim;
> > gfc_expr *temp;
> > gfc_ref *ref = dataref->next;
> > ref->u.ar.type = AR_SECTION;
> > /* We have to set up the array reference to give ranges
> > in all dimensions and ensure that the end and stride
> > are set so that the copy can be scalarized. */
> > - dim = 0;
> > for (; dim < dataref->u.c.component->as->rank; dim++)
> > {
> > ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
> > --- 5758,5815 ----
> >
> > if (dataref && dataref->u.c.component->as)
> > {
> > ! int dim = 0;
> > gfc_expr *temp;
> > gfc_ref *ref = dataref->next;
> > ref->u.ar.type = AR_SECTION;
> > + if (code->ext.alloc.arr_spec_from_expr3)
> > + {
> > + /* Take the array dimensions from the
> > + source=-expression. */
> > + gfc_array_ref *source_ref =
> > + gfc_find_array_ref (code->expr3);
> Does this work? code->expr3 is not always a variable.
The block removed from resolve_allocate() ensured, that this was always a
variable. Therefore, yes, it had to work then. Now, we of course have far more
trouble.
>
> > + if (source_ref->type == AR_FULL)
> > + {
> > + /* For full array refs copy the bounds. */
> > + for (; dim < dataref->u.c.component->as->rank;
> > dim++)
> > + {
> > + ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
> > + ref->u.ar.start[dim] =
> > + gfc_copy_expr
> > (source_ref->as->lower[dim]);
> > + ref->u.ar.end[dim] =
> > + gfc_copy_expr
> > (source_ref->as->upper[dim]);
> > + }
> This won't work. Consider this:
> block
> integer :: a(n)
> n = n+1
> allocate(b, source=a)
> end block
>
> You have to use a full array ref. In fact you can use a full array ref
> everywhere, I think.
I don't get you there. Using a full array ref produces numerous regressions.
Have a look at the current patch. The full array ref is in the
#if-#else-#endif's #else block. Any ideas?
Bootstraps and regtests fine on x86_64-linux-gnu.
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr44672_7.patch --]
[-- Type: text/x-patch, Size: 27404 bytes --]
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 905d47c..211c781 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2396,6 +2396,9 @@ typedef struct gfc_code
{
gfc_typespec ts;
gfc_alloc *list;
+ /* Take the array specification from expr3 to allocate arrays
+ without an explicit array specification. */
+ unsigned arr_spec_from_expr3:1;
}
alloc;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e615cc6..315170a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6805,7 +6805,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
have a trailing array reference that gives the size of the array. */
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 codimension;
@@ -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
|| (dimension && ref2->u.ar.dimen == 0))
{
- gfc_error ("Array specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
+ /* F08:C633. */
+ if (code->expr3)
+ {
+ 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
- context of an ALLOCATE specification. */
+ context of an ALLOCATE specification. */
ar = &ref2->u.ar;
@@ -7125,7 +7136,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
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;
switch (ar->dimen_type[i])
@@ -7202,6 +7213,7 @@ failure:
return false;
}
+
static void
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)
{
+ bool arr_alloc_wo_spec = false;
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
{
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index c8fab45..014ee53 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5005,7 +5005,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
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)
{
tree type;
tree tmp;
@@ -5020,7 +5021,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tree var;
stmtblock_t thenblock;
stmtblock_t elseblock;
- gfc_expr *ubound;
+ gfc_expr *ubound = NULL;
gfc_se se;
int n;
@@ -5035,6 +5036,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
or_expr = boolean_false_node;
+ /* When expr3_desc is set, use its rank, because we want to allocate an
+ array with the array_spec coming from source=. */
+ if (expr3_desc != NULL_TREE)
+ rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (expr3_desc));
+
for (n = 0; n < rank; n++)
{
tree conv_lbound;
@@ -5044,24 +5050,29 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
lower == NULL => lbound = 1, ubound = upper[n]
upper[n] = NULL => lbound = 1, ubound = lower[n]
upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
- ubound = upper[n];
/* Set lower bound. */
gfc_init_se (&se, NULL);
- if (lower == NULL)
+ if (expr3_desc != NULL_TREE)
se.expr = gfc_index_one_node;
else
{
- gcc_assert (lower[n]);
- if (ubound)
- {
- gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
- }
+ ubound = upper[n];
+ if (lower == NULL)
+ se.expr = gfc_index_one_node;
else
{
- se.expr = gfc_index_one_node;
- ubound = lower[n];
+ gcc_assert (lower[n]);
+ if (ubound)
+ {
+ gfc_conv_expr_type (&se, lower[n], gfc_array_index_type);
+ gfc_add_block_to_block (pblock, &se.pre);
+ }
+ else
+ {
+ se.expr = gfc_index_one_node;
+ ubound = lower[n];
+ }
}
}
gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
@@ -5076,10 +5087,25 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set upper bound. */
gfc_init_se (&se, NULL);
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
-
+ if (expr3_desc != NULL_TREE)
+ {
+ /* Set 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]));
+ se.expr = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, tmp,
+ gfc_index_one_node);
+ }
+ 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_rank_cst[n], se.expr);
conv_ubound = se.expr;
@@ -5249,6 +5275,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
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
@@ -5256,7 +5309,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3)
+ tree *nelems, gfc_expr *expr3, tree e3_arr_desc)
{
tree tmp;
tree pointer;
@@ -5274,21 +5327,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable, coarray, dimension;
+ bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
/* 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
- || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
- prev_ref = ref;
- ref = ref->next;
- }
+ /* F08:C633: Array shape from expr3. */
+ ref = expr3->ref;
- if (ref == NULL || ref->type != REF_ARRAY)
- return false;
+ /* Find the last reference in the chain. */
+ if (!retrieve_last_ref (&ref, &prev_ref))
+ return false;
+ alloc_w_e3_arr_spec = true;
+ }
if (!prev_ref)
{
@@ -5324,7 +5380,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
break;
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;
upper = ref->u.ar.as->upper;
@@ -5338,10 +5395,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
overflow = integer_zero_node;
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,
&se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3);
+ expr3_elem_size, nelems, expr3, e3_arr_desc);
if (dimension)
{
@@ -7080,6 +7138,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
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)
{
/* Get a pointer to the new descriptor. */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 2155b58..6e5378f 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -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
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *);
+ tree, tree *, gfc_expr *, tree);
/* 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 *,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9be8a42..3916836 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5328,7 +5328,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
&& e->ts.u.derived->attr.alloc_comp
&& !(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;
tmp = build_fold_indirect_ref_loc (input_location,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 81943b0..c9c112f 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5104,7 +5104,7 @@ gfc_trans_allocate (gfc_code * code)
element size, i.e. _vptr%size, is stored in expr3_esize. Any of
the trees may be the NULL_TREE indicating that this is not
available for expr3's type. */
- tree expr3, expr3_vptr, expr3_len, expr3_esize;
+ tree expr3, expr3_vptr, expr3_len, expr3_esize, expr3_desc;
stmtblock_t block;
stmtblock_t post;
tree nelems;
@@ -5117,6 +5117,7 @@ gfc_trans_allocate (gfc_code * code)
stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+ expr3_desc = NULL_TREE;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -5174,21 +5175,31 @@ gfc_trans_allocate (gfc_code * code)
{
if (!code->expr3->mold
|| code->expr3->ts.type == BT_CHARACTER
- || vtab_needed)
+ || vtab_needed
+ || code->ext.alloc.arr_spec_from_expr3)
{
/* Convert expr3 to a tree. */
gfc_init_se (&se, NULL);
- /* For all "simple" expression just get the descriptor or the
- reference, respectively, depending on the rank of the expr. */
- if (code->expr3->rank != 0)
- gfc_conv_expr_descriptor (&se, code->expr3);
- else
- gfc_conv_expr_reference (&se, code->expr3);
- if (!code->expr3->mold)
- expr3 = se.expr;
+ if (code->ext.alloc.arr_spec_from_expr3)
+ {
+ gfc_conv_expr_descriptor (&se, code->expr3);
+ expr3_desc = se.expr;
+ }
else
- expr3_tmp = se.expr;
- expr3_len = se.string_length;
+ {
+ /* For all "simple" expression just get the descriptor
+ or the reference, respectively, depending on the
+ rank of the expr. */
+ if (code->expr3->rank != 0)
+ gfc_conv_expr_descriptor (&se, code->expr3);
+ else
+ gfc_conv_expr_reference (&se, code->expr3);
+ if (!code->expr3->mold)
+ expr3 = se.expr;
+ else
+ expr3_tmp = se.expr;
+ expr3_len = se.string_length;
+ }
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
}
@@ -5215,7 +5226,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
/* Prevent aliasing, i.e., se.expr may be already a
- variable declaration. */
+ variable declaration. */
if (!VAR_P (se.expr))
{
tree var;
@@ -5229,7 +5240,9 @@ gfc_trans_allocate (gfc_code * code)
}
else
tmp = se.expr;
- if (!code->expr3->mold)
+ if (code->ext.alloc.arr_spec_from_expr3)
+ expr3_desc = tmp;
+ else if (!code->expr3->mold)
expr3 = tmp;
else
expr3_tmp = tmp;
@@ -5291,6 +5304,7 @@ gfc_trans_allocate (gfc_code * code)
}
else
{
+ tree inexpr3;
/* When the object to allocate is polymorphic type, then it
needs its vtab set correctly, so deduce the required _vtab
and _len from the source expression. */
@@ -5339,7 +5353,9 @@ gfc_trans_allocate (gfc_code * code)
don't have to take care about scalar to array treatment and
will benefit of every enhancements gfc_trans_assignment ()
gets. */
- if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
+ inexpr3 = expr3_desc ? expr3_desc : expr3;
+ if (inexpr3 != NULL_TREE && DECL_P (inexpr3)
+ && DECL_ARTIFICIAL (inexpr3))
{
/* Build a temporary symtree and symbol. Do not add it to
the current namespace to prevent accidently modifying
@@ -5349,11 +5365,11 @@ gfc_trans_allocate (gfc_code * code)
gfc_create_var () took care about generating the
identifier. */
newsym->name = gfc_get_string (IDENTIFIER_POINTER (
- DECL_NAME (expr3)));
+ DECL_NAME (inexpr3)));
newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
/* The backend_decl is known. It is expr3, which is inserted
here. */
- newsym->n.sym->backend_decl = expr3;
+ newsym->n.sym->backend_decl = inexpr3;
e3rhs = gfc_get_expr ();
e3rhs->ts = code->expr3->ts;
e3rhs->rank = code->expr3->rank;
@@ -5379,7 +5395,7 @@ gfc_trans_allocate (gfc_code * code)
newsym->n.sym->as = arr;
gfc_add_full_array_ref (e3rhs, arr);
}
- else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
+ else if (POINTER_TYPE_P (TREE_TYPE (inexpr3)))
newsym->n.sym->attr.pointer = 1;
/* The string length is known to. Set it for char arrays. */
if (e3rhs->ts.type == BT_CHARACTER)
@@ -5490,7 +5506,8 @@ gfc_trans_allocate (gfc_code * code)
else
tmp = expr3_esize;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems, code->expr3))
+ label_finish, tmp, &nelems,
+ e3rhs ? e3rhs : code->expr3, expr3_desc))
{
/* A scalar or derived type. First compute the size to
allocate.
@@ -5693,17 +5710,26 @@ gfc_trans_allocate (gfc_code * code)
{
/* Initialization via SOURCE block (or static default initializer).
Classes need some special handling, so catch them first. */
- if (expr3 != NULL_TREE
- && ((POINTER_TYPE_P (TREE_TYPE (expr3))
- && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
- || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))))
+ if ((expr3_desc != NULL_TREE
+ || (expr3 != NULL_TREE
+ && ((POINTER_TYPE_P (TREE_TYPE (expr3))
+ && TREE_CODE (expr3) != POINTER_PLUS_EXPR)
+ || (VAR_P (expr3) && GFC_CLASS_TYPE_P (
+ TREE_TYPE (expr3))))))
&& code->expr3->ts.type == BT_CLASS
&& (expr->ts.type == BT_CLASS
|| expr->ts.type == BT_DERIVED))
{
- tree to;
+ /* copy_class_to_class can be used for class arrays, too.
+ It just needs to be ensured, that the decl_saved_descriptor
+ has a way to get to the vptr. */
+ tree to, from;
to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
- tmp = gfc_copy_class_to_class (expr3, to,
+ /* Only use the array descriptor in expr3_desc, when it is
+ set and not in a mold= expression. */
+ from = expr3_desc == NULL_TREE || code->expr3->mold ?
+ expr3 : GFC_DECL_SAVED_DESCRIPTOR (expr3_desc);
+ tmp = gfc_copy_class_to_class (from, to,
nelems, upoly_expr);
}
else if (al->expr->ts.type == BT_CLASS)
@@ -5734,30 +5760,86 @@ gfc_trans_allocate (gfc_code * code)
if (dataref && dataref->u.c.component->as)
{
- int dim;
+#if 1
+ int dim = 0;
gfc_expr *temp;
gfc_ref *ref = dataref->next;
ref->u.ar.type = AR_SECTION;
- /* We have to set up the array reference to give ranges
- in all dimensions and ensure that the end and stride
- are set so that the copy can be scalarized. */
- dim = 0;
- for (; dim < dataref->u.c.component->as->rank; dim++)
+ if (code->ext.alloc.arr_spec_from_expr3)
+ {
+ /* Take the array dimensions from the
+ source=-expression. */
+ gfc_array_ref *source_ref =
+ gfc_find_array_ref (e3rhs ? e3rhs : code->expr3);
+ if (source_ref->type == AR_FULL)
+ {
+ /* For full array refs copy the bounds. */
+ for (; dim < dataref->u.c.component->as->rank; dim++)
+ {
+ ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+ ref->u.ar.start[dim] =
+ gfc_copy_expr (source_ref->as->lower[dim]);
+ ref->u.ar.end[dim] =
+ gfc_copy_expr (source_ref->as->upper[dim]);
+ }
+ }
+ else
+ {
+ int sdim = 0;
+ /* For partial array refs, the partials. */
+ for (; dim < dataref->u.c.component->as->rank;
+ dim++, sdim++)
+ {
+ ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+ ref->u.ar.start[dim] =
+ gfc_get_int_expr (gfc_default_integer_kind,
+ &al->expr->where, 1);
+ /* Skip over element dimensions. */
+ while (source_ref->dimen_type[sdim]
+ == DIMEN_ELEMENT)
+ ++sdim;
+ temp = gfc_subtract (gfc_copy_expr (
+ source_ref->end[sdim]),
+ gfc_copy_expr (
+ source_ref->start[sdim]));
+ ref->u.ar.end[dim] = gfc_add (temp,
+ gfc_get_int_expr (gfc_default_integer_kind,
+ &al->expr->where, 1));
+ }
+ }
+ }
+ else
{
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- if (ref->u.ar.end[dim] == NULL)
+ /* We have to set up the array reference to give ranges
+ in all dimensions and ensure that the end and stride
+ are set so that the copy can be scalarized. */
+ for (; dim < dataref->u.c.component->as->rank; dim++)
{
- ref->u.ar.end[dim] = ref->u.ar.start[dim];
- temp = gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1);
- ref->u.ar.start[dim] = temp;
+ ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
+ if (ref->u.ar.end[dim] == NULL)
+ {
+ ref->u.ar.end[dim] = ref->u.ar.start[dim];
+ temp = gfc_get_int_expr (gfc_default_integer_kind,
+ &al->expr->where, 1);
+ ref->u.ar.start[dim] = temp;
+ }
+ temp = gfc_subtract (gfc_copy_expr (
+ ref->u.ar.end[dim]),
+ gfc_copy_expr (
+ ref->u.ar.start[dim]));
+ temp = gfc_add (gfc_get_int_expr (
+ gfc_default_integer_kind,
+ &al->expr->where, 1),
+ temp);
}
- temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
- gfc_copy_expr (ref->u.ar.start[dim]));
- temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1),
- temp);
}
+#else
+ gfc_free_ref_list (dataref->next);
+ dataref->next = NULL;
+ gfc_add_full_array_ref (last_arg->expr,
+ gfc_get_full_arrayspec_from_expr (e3rhs ? e3rhs
+ : code->expr3));
+#endif
}
if (rhs->ts.type == BT_CLASS)
{
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
index f7e0109..59d08d6 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
@@ -1,28 +1,110 @@
-! { dg-do compile }
+! { dg-do run }
!
! Contributed by Reinhold Bader
!
program assumed_shape_01
- use, intrinsic :: iso_c_binding
implicit none
- type, bind(c) :: cstruct
- integer(c_int) :: i
- real(c_float) :: r(2)
+ type :: cstruct
+ integer :: i
+ real :: r(2)
end type cstruct
- interface
- subroutine psub(this, that) bind(c, name='Psub')
- import :: c_float, cstruct
- real(c_float) :: this(:,:)
- type(cstruct) :: that(:)
- end subroutine psub
- end interface
-
- real(c_float) :: t(3,7)
+
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 (u(1)%i /= 4 .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) call abort()
+ deallocate (u)
-! 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" }
- call psub(t, 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
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08
new file mode 100644
index 0000000..86df531
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_6.f08
@@ -0,0 +1,79 @@
+! { 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
+
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec
2015-05-28 15:48 ` Andre Vehreschild
@ 2015-05-28 18:42 ` Mikael Morin
2015-05-29 12:41 ` Andre Vehreschild
0 siblings, 1 reply; 21+ messages in thread
From: Mikael Morin @ 2015-05-28 18:42 UTC (permalink / raw)
To: Andre Vehreschild; +Cc: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 8511 bytes --]
Le 28/05/2015 17:29, Andre Vehreschild a écrit :
> *************** resolve_allocate_expr (gfc_expr *e, gfc_
> *** 7103,7112 ****
> --- 7103,7123 ----
> if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
> || (dimension && ref2->u.ar.dimen == 0))
> {
> + /* F08:C633. */
> + if (code->expr3)
> + {
> + 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
> context of an ALLOCATE specification. */
I think we can be a little be more user friendly with the gfc_notify_std
error message.
Something like:
ALLOCATE without array spec at %L
ALLOCATE with array bounds determined from SOURCE or MOLD at %L
> *************** gfc_array_init_size (tree descriptor, in
> *** 5044,5053 ****
> lower == NULL => lbound = 1, ubound = upper[n]
> upper[n] = NULL => lbound = 1, ubound = lower[n]
> upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
> - ubound = upper[n];
>
> /* Set lower bound. */
> gfc_init_se (&se, NULL);
> if (lower == NULL)
> se.expr = gfc_index_one_node;
> else
> --- 5050,5063 ----
> lower == NULL => lbound = 1, ubound = upper[n]
> upper[n] = NULL => lbound = 1, ubound = lower[n]
> upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
>
> /* Set lower bound. */
> gfc_init_se (&se, NULL);
> + if (expr3_desc != NULL_TREE)
> + se.expr = gfc_index_one_node;
> + else
> + {
> + ubound = upper[n];
> if (lower == NULL)
> se.expr = gfc_index_one_node;
> else
> *************** gfc_array_init_size (tree descriptor, in
> *** 5064,5069 ****
> --- 5074,5080 ----
> ubound = lower[n];
> }
> }
> + }
> gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
> gfc_rank_cst[n], se.expr);
> conv_lbound = se.expr;
You can avoid reindenting if the ubound = upper[n] statement is kept at
its original place.
> *************** gfc_array_init_size (tree descriptor, in
> *** 5076,5085 ****
>
> /* Set upper bound. */
> gfc_init_se (&se, NULL);
> 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_rank_cst[n], se.expr);
> conv_ubound = se.expr;
> --- 5087,5111 ----
>
> /* Set upper bound. */
> gfc_init_se (&se, NULL);
> + if (expr3_desc != NULL_TREE)
> + {
> + /* Set 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]));
> + se.expr = fold_build2_loc (input_location, PLUS_EXPR,
> + gfc_array_index_type, tmp,
> + gfc_index_one_node);
> + }
> + 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_rank_cst[n], se.expr);
> conv_ubound = se.expr;
Your one-based-ness problem was here, wasn't it?
I would rather copy directly lbound and ubound from expr3_desc to
descriptor.
If the source has non-one-based bounds, the above would produce wrong
bounds.
> *************** gfc_trans_allocate (gfc_code * code)
> *** 5174,5185 ****
> {
> if (!code->expr3->mold
> || code->expr3->ts.type == BT_CHARACTER
> ! || vtab_needed)
> {
> /* Convert expr3 to a tree. */
> gfc_init_se (&se, NULL);
> ! /* For all "simple" expression just get the descriptor or the
> ! reference, respectively, depending on the rank of the expr. */
> if (code->expr3->rank != 0)
> gfc_conv_expr_descriptor (&se, code->expr3);
> else
> --- 5175,5195 ----
> {
> if (!code->expr3->mold
> || code->expr3->ts.type == BT_CHARACTER
> ! || vtab_needed
> ! || code->ext.alloc.arr_spec_from_expr3)
> {
> /* Convert expr3 to a tree. */
> gfc_init_se (&se, NULL);
> ! if (code->ext.alloc.arr_spec_from_expr3)
> ! {
> ! gfc_conv_expr_descriptor (&se, code->expr3);
> ! expr3_desc = se.expr;
> ! }
> ! else
> ! {
> ! /* For all "simple" expression just get the descriptor
> ! or the reference, respectively, depending on the
> ! rank of the expr. */
> if (code->expr3->rank != 0)
> gfc_conv_expr_descriptor (&se, code->expr3);
> else
> *************** gfc_trans_allocate (gfc_code * code)
> *** 5189,5194 ****
> --- 5199,5205 ----
> else
> expr3_tmp = se.expr;
> expr3_len = se.string_length;
> + }
> gfc_add_block_to_block (&block, &se.pre);
> gfc_add_block_to_block (&post, &se.post);
> }
This is skipping over setting expr3_len, is it on purpose?
Would it make sense to merge the two calls to gfc_conv_expr_descriptor?
> *************** gfc_trans_allocate (gfc_code * code)
> *** 5229,5235 ****
> }
> else
> tmp = se.expr;
> ! if (!code->expr3->mold)
> expr3 = tmp;
> else
> expr3_tmp = tmp;
> --- 5240,5248 ----
> }
> else
> tmp = se.expr;
> ! if (code->ext.alloc.arr_spec_from_expr3)
> ! expr3_desc = tmp;
> ! else if (!code->expr3->mold)
> expr3 = tmp;
> else
> expr3_tmp = tmp;
Couldn't expr3 be reused?
We had code->expr3, expr3, expr3rhs, and now this is adding expr3_desc,
and (below) inexpr3. :-(
> *************** gfc_trans_allocate (gfc_code * code)
> *** 5291,5296 ****
> --- 5304,5310 ----
> }
> else
> {
> + tree inexpr3;
> /* When the object to allocate is polymorphic type, then it
> needs its vtab set correctly, so deduce the required _vtab
> and _len from the source expression. */
> *************** gfc_trans_allocate (gfc_code * code)
> *** 5339,5345 ****
> don't have to take care about scalar to array treatment and
> will benefit of every enhancements gfc_trans_assignment ()
> gets. */
> ! if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
> {
> /* Build a temporary symtree and symbol. Do not add it to
> the current namespace to prevent accidently modifying
> --- 5353,5361 ----
> don't have to take care about scalar to array treatment and
> will benefit of every enhancements gfc_trans_assignment ()
> gets. */
> ! inexpr3 = expr3_desc ? expr3_desc : expr3;
> ! if (inexpr3 != NULL_TREE && DECL_P (inexpr3)
> ! && DECL_ARTIFICIAL (inexpr3))
> {
> /* Build a temporary symtree and symbol. Do not add it to
> the current namespace to prevent accidently modifying
>
[...]
>>> + if (source_ref->type == AR_FULL)
>>> + {
>>> + /* For full array refs copy the bounds. */
>>> + for (; dim < dataref->u.c.component->as->rank;
>>> dim++)
>>> + {
>>> + ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
>>> + ref->u.ar.start[dim] =
>>> + gfc_copy_expr
>>> (source_ref->as->lower[dim]);
>>> + ref->u.ar.end[dim] =
>>> + gfc_copy_expr
>>> (source_ref->as->upper[dim]);
>>> + }
>> This won't work. Consider this:
>> block
>> integer :: a(n)
>> n = n+1
>> allocate(b, source=a)
>> end block
>>
>> You have to use a full array ref. In fact you can use a full array ref
>> everywhere, I think.
>
> I don't get you there. Using a full array ref produces numerous regressions.
> Have a look at the current patch. The full array ref is in the
> #if-#else-#endif's #else block. Any ideas?
>
The attached patch seems to work. It is basically the same as your
#else branch.
I think the problem was gfc_get_full_arrayspec_from_expr can return NULL
in some cases.
Mikael
[-- Attachment #2: pr44672_v7.1.diff --]
[-- Type: text/x-patch, Size: 3185 bytes --]
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index a2f8216..b3d3ddc 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5759,86 +5759,15 @@ gfc_trans_allocate (gfc_code * code)
if (dataref && dataref->u.c.component->as)
{
-#if 1
- int dim = 0;
- gfc_expr *temp;
- gfc_ref *ref = dataref->next;
- ref->u.ar.type = AR_SECTION;
- if (code->ext.alloc.arr_spec_from_expr3)
- {
- /* Take the array dimensions from the
- source=-expression. */
- gfc_array_ref *source_ref =
- gfc_find_array_ref (e3rhs ? e3rhs : code->expr3);
- if (source_ref->type == AR_FULL)
- {
- /* For full array refs copy the bounds. */
- for (; dim < dataref->u.c.component->as->rank; dim++)
- {
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- ref->u.ar.start[dim] =
- gfc_copy_expr (source_ref->as->lower[dim]);
- ref->u.ar.end[dim] =
- gfc_copy_expr (source_ref->as->upper[dim]);
- }
- }
- else
- {
- int sdim = 0;
- /* For partial array refs, the partials. */
- for (; dim < dataref->u.c.component->as->rank;
- dim++, sdim++)
- {
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- ref->u.ar.start[dim] =
- gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1);
- /* Skip over element dimensions. */
- while (source_ref->dimen_type[sdim]
- == DIMEN_ELEMENT)
- ++sdim;
- temp = gfc_subtract (gfc_copy_expr (
- source_ref->end[sdim]),
- gfc_copy_expr (
- source_ref->start[sdim]));
- ref->u.ar.end[dim] = gfc_add (temp,
- gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1));
- }
- }
- }
- else
- {
- /* We have to set up the array reference to give ranges
- in all dimensions and ensure that the end and stride
- are set so that the copy can be scalarized. */
- for (; dim < dataref->u.c.component->as->rank; dim++)
- {
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- if (ref->u.ar.end[dim] == NULL)
- {
- ref->u.ar.end[dim] = ref->u.ar.start[dim];
- temp = gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1);
- ref->u.ar.start[dim] = temp;
- }
- temp = gfc_subtract (gfc_copy_expr (
- ref->u.ar.end[dim]),
- gfc_copy_expr (
- ref->u.ar.start[dim]));
- temp = gfc_add (gfc_get_int_expr (
- gfc_default_integer_kind,
- &al->expr->where, 1),
- temp);
- }
- }
-#else
+ gfc_array_spec *as = dataref->u.c.component->as;
+
gfc_free_ref_list (dataref->next);
dataref->next = NULL;
- gfc_add_full_array_ref (last_arg->expr,
- gfc_get_full_arrayspec_from_expr (e3rhs ? e3rhs
- : code->expr3));
-#endif
+ gfc_add_full_array_ref (last_arg->expr, as);
+ gfc_resolve_expr (last_arg->expr);
+ gcc_assert (last_arg->expr->ts.type == BT_CLASS
+ || last_arg->expr->ts.type == BT_DERIVED);
+ last_arg->expr->ts.type = BT_CLASS;
}
if (rhs->ts.type == BT_CLASS)
{
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec
2015-05-28 18:42 ` Mikael Morin
@ 2015-05-29 12:41 ` Andre Vehreschild
2015-05-30 4:23 ` Thomas Koenig
2015-06-02 16:52 ` Mikael Morin
0 siblings, 2 replies; 21+ messages in thread
From: Andre Vehreschild @ 2015-05-29 12:41 UTC (permalink / raw)
To: Mikael Morin; +Cc: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 6130 bytes --]
Hi Mikael,
comments inline below:
On Thu, 28 May 2015 20:06:57 +0200
Mikael Morin <mikael.morin@sfr.fr> wrote:
> Le 28/05/2015 17:29, Andre Vehreschild a écrit :
> > *************** resolve_allocate_expr (gfc_expr *e, gfc_
> > *** 7103,7112 ****
> > --- 7103,7123 ----
> > if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
> > || (dimension && ref2->u.ar.dimen == 0))
> > {
> > + /* F08:C633. */
> > + if (code->expr3)
> > + {
> > + 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
> > context of an ALLOCATE specification. */
> I think we can be a little be more user friendly with the gfc_notify_std
> error message.
> Something like:
> ALLOCATE without array spec at %L
> ALLOCATE with array bounds determined from SOURCE or MOLD at %L
I didn't want to mess with the error messages to prevent issues for
translations. So how is the policy on this?
> > *************** gfc_array_init_size (tree descriptor, in
> > *** 5044,5053 ****
> > lower == NULL => lbound = 1, ubound = upper[n]
> > upper[n] = NULL => lbound = 1, ubound = lower[n]
> > upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
> > - ubound = upper[n];
> >
> > /* Set lower bound. */
> > gfc_init_se (&se, NULL);
> > if (lower == NULL)
> > se.expr = gfc_index_one_node;
> > else
> > --- 5050,5063 ----
> > lower == NULL => lbound = 1, ubound = upper[n]
> > upper[n] = NULL => lbound = 1, ubound = lower[n]
> > upper[n] != NULL => lbound = lower[n], ubound = upper[n] */
> >
> > /* Set lower bound. */
> > gfc_init_se (&se, NULL);
> > + if (expr3_desc != NULL_TREE)
> > + se.expr = gfc_index_one_node;
> > + else
> > + {
> > + ubound = upper[n];
> > if (lower == NULL)
> > se.expr = gfc_index_one_node;
> > else
> > *************** gfc_array_init_size (tree descriptor, in
> > *** 5064,5069 ****
> > --- 5074,5080 ----
> > ubound = lower[n];
> > }
> > }
> > + }
> > gfc_conv_descriptor_lbound_set (descriptor_block, descriptor,
> > gfc_rank_cst[n], se.expr);
> > conv_lbound = se.expr;
> You can avoid reindenting if the ubound = upper[n] statement is kept at
> its original place.
Fixed.
> > *************** gfc_array_init_size (tree descriptor, in
> > *** 5076,5085 ****
> >
> > /* Set upper bound. */
> > gfc_init_se (&se, NULL);
> > 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_rank_cst[n], se.expr);
> > conv_ubound = se.expr;
> > --- 5087,5111 ----
> >
> > /* Set upper bound. */
> > gfc_init_se (&se, NULL);
> > + if (expr3_desc != NULL_TREE)
> > + {
> > + /* Set 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]));
> > + se.expr = fold_build2_loc (input_location, PLUS_EXPR,
> > + gfc_array_index_type, tmp,
> > + gfc_index_one_node);
> > + }
> > + 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_rank_cst[n], se.expr);
> > conv_ubound = se.expr;
> Your one-based-ness problem was here, wasn't it?
Correct.
> I would rather copy directly lbound and ubound from expr3_desc to
> descriptor.
It was that way in the previous version of the patch, which does *not* work any
longer. When gfc_trans_allocate () is responsible for the creating a temporary
variable for the source=-expression, then it does so using zero based
expressions.
> If the source has non-one-based bounds, the above would produce wrong
> bounds.
Counterexample? Note, the expr3_desc is guaranteed to be an artificial variable
created by conv_expr_descriptor, aka zero-based.
<snipp>
> > *************** gfc_trans_allocate (gfc_code * code)
> > *** 5229,5235 ****
> > }
> > else
> > tmp = se.expr;
> > ! if (!code->expr3->mold)
> > expr3 = tmp;
> > else
> > expr3_tmp = tmp;
> > --- 5240,5248 ----
> > }
> > else
> > tmp = se.expr;
> > ! if (code->ext.alloc.arr_spec_from_expr3)
> > ! expr3_desc = tmp;
> > ! else if (!code->expr3->mold)
> > expr3 = tmp;
> > else
> > expr3_tmp = tmp;
> Couldn't expr3 be reused?
> We had code->expr3, expr3, expr3rhs, and now this is adding expr3_desc,
> and (below) inexpr3. :-(
Of course can we use just two variables for all expressions. I have removed the
expr3_tmp, inexpr3 and expr3_desc and introduced a e3_is enumeration, which
stores which kind the expr3 is, aka unset, source, mold, desc. This makes the
code simpler at some places.
Attached is a new version of the patch. This one fails
allocate_with_source_3.f90 on runtime, where I don't see the issue currently.
May be you have some luck and time. If not I will investigate on Monday.
Regards,
Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr44672_7.1.patch --]
[-- Type: text/x-patch, Size: 26205 bytes --]
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 905d47c..211c781 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2396,6 +2396,9 @@ typedef struct gfc_code
{
gfc_typespec ts;
gfc_alloc *list;
+ /* Take the array specification from expr3 to allocate arrays
+ without an explicit array specification. */
+ unsigned arr_spec_from_expr3:1;
}
alloc;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e615cc6..315170a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6805,7 +6805,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
have a trailing array reference that gives the size of the array. */
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 codimension;
@@ -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
|| (dimension && ref2->u.ar.dimen == 0))
{
- gfc_error ("Array specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
+ /* F08:C633. */
+ if (code->expr3)
+ {
+ 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
- context of an ALLOCATE specification. */
+ context of an ALLOCATE specification. */
ar = &ref2->u.ar;
@@ -7125,7 +7136,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
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;
switch (ar->dimen_type[i])
@@ -7202,6 +7213,7 @@ failure:
return false;
}
+
static void
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)
{
+ bool arr_alloc_wo_spec = false;
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
{
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index c8fab45..6a31396 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5005,7 +5005,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
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)
{
tree type;
tree tmp;
@@ -5020,7 +5021,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tree var;
stmtblock_t thenblock;
stmtblock_t elseblock;
- gfc_expr *ubound;
+ gfc_expr *ubound = NULL;
gfc_se se;
int n;
@@ -5035,6 +5036,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
or_expr = boolean_false_node;
+ /* When expr3_desc is set, use its rank, because we want to allocate an
+ array with the array_spec coming from source=. */
+ if (expr3_desc != NULL_TREE)
+ rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (expr3_desc));
+
for (n = 0; n < rank; n++)
{
tree conv_lbound;
@@ -5048,7 +5054,9 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set lower bound. */
gfc_init_se (&se, NULL);
- if (lower == NULL)
+ if (expr3_desc != NULL_TREE)
+ se.expr = gfc_index_one_node;
+ else if (lower == NULL)
se.expr = gfc_index_one_node;
else
{
@@ -5076,10 +5084,25 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set upper bound. */
gfc_init_se (&se, NULL);
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
-
+ if (expr3_desc != NULL_TREE)
+ {
+ /* Set 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]));
+ se.expr = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, tmp,
+ gfc_index_one_node);
+ }
+ 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_rank_cst[n], se.expr);
conv_ubound = se.expr;
@@ -5249,6 +5272,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
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
@@ -5256,7 +5306,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3)
+ tree *nelems, gfc_expr *expr3, tree e3_arr_desc)
{
tree tmp;
tree pointer;
@@ -5274,21 +5324,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable, coarray, dimension;
+ bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
/* 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
- || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
- prev_ref = ref;
- ref = ref->next;
- }
+ /* F08:C633: Array shape from expr3. */
+ ref = expr3->ref;
- if (ref == NULL || ref->type != REF_ARRAY)
- return false;
+ /* Find the last reference in the chain. */
+ if (!retrieve_last_ref (&ref, &prev_ref))
+ return false;
+ alloc_w_e3_arr_spec = true;
+ }
if (!prev_ref)
{
@@ -5324,7 +5377,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
break;
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;
upper = ref->u.ar.as->upper;
@@ -5338,10 +5392,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
overflow = integer_zero_node;
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,
&se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3);
+ expr3_elem_size, nelems, expr3, e3_arr_desc);
if (dimension)
{
@@ -7080,6 +7135,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
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)
{
/* Get a pointer to the new descriptor. */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 2155b58..6e5378f 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -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
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *);
+ tree, tree *, gfc_expr *, tree);
/* 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 *,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9be8a42..3916836 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5328,7 +5328,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
&& e->ts.u.derived->attr.alloc_comp
&& !(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;
tmp = build_fold_indirect_ref_loc (input_location,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 81943b0..43bc34a 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5105,6 +5105,8 @@ gfc_trans_allocate (gfc_code * code)
the trees may be the NULL_TREE indicating that this is not
available for expr3's type. */
tree expr3, expr3_vptr, expr3_len, expr3_esize;
+ /* Classify what expr3 stores. */
+ enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
stmtblock_t block;
stmtblock_t post;
tree nelems;
@@ -5117,6 +5119,7 @@ gfc_trans_allocate (gfc_code * code)
stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+ e3_is = E3_UNSET;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -5156,10 +5159,7 @@ gfc_trans_allocate (gfc_code * code)
expression. */
if (code->expr3)
{
- bool vtab_needed = false;
- /* expr3_tmp gets the tree when code->expr3.mold is set, i.e.,
- the expression is only needed to get the _vptr, _len a.s.o. */
- tree expr3_tmp = NULL_TREE;
+ bool vtab_needed = false, temp_var_needed = false;
/* Figure whether we need the vtab from expr3. */
for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
@@ -5174,25 +5174,26 @@ gfc_trans_allocate (gfc_code * code)
{
if (!code->expr3->mold
|| code->expr3->ts.type == BT_CHARACTER
- || vtab_needed)
+ || vtab_needed
+ || code->ext.alloc.arr_spec_from_expr3)
{
/* Convert expr3 to a tree. */
gfc_init_se (&se, NULL);
- /* For all "simple" expression just get the descriptor or the
- reference, respectively, depending on the rank of the expr. */
- if (code->expr3->rank != 0)
+ /* For all "simple" expression just get the descriptor
+ or the reference, respectively, depending on the
+ rank of the expr. */
+ if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0)
gfc_conv_expr_descriptor (&se, code->expr3);
else
gfc_conv_expr_reference (&se, code->expr3);
- if (!code->expr3->mold)
- expr3 = se.expr;
- else
- expr3_tmp = se.expr;
+ /* Create a temp variable only for component refs. */
+ temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF;
expr3_len = se.string_length;
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
}
- /* else expr3 = NULL_TREE set above. */
+ else
+ se.expr = NULL_TREE;
}
else
{
@@ -5212,32 +5213,41 @@ gfc_trans_allocate (gfc_code * code)
code->expr3->ts,
false, true,
false, false);
+ temp_var_needed = !VAR_P (se.expr);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
- /* Prevent aliasing, i.e., se.expr may be already a
- variable declaration. */
- if (!VAR_P (se.expr))
- {
- tree var;
- tmp = build_fold_indirect_ref_loc (input_location,
- se.expr);
- /* We need a regular (non-UID) symbol here, therefore give a
- prefix. */
- var = gfc_create_var (TREE_TYPE (tmp), "atmp");
- gfc_add_modify_loc (input_location, &block, var, tmp);
- tmp = var;
- }
- else
- tmp = se.expr;
- if (!code->expr3->mold)
- expr3 = tmp;
- else
- expr3_tmp = tmp;
/* When he length of a char array is easily available
- here, fix it for future use. */
+ here, fix it for future use. */
if (se.string_length)
expr3_len = gfc_evaluate_now (se.string_length, &block);
}
+ /* Prevent aliasing, i.e., se.expr may be already a
+ variable declaration. */
+ if (se.expr != NULL_TREE && temp_var_needed)
+ {
+ tree var;
+ tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ?
+ se.expr
+ : build_fold_indirect_ref_loc (input_location, se.expr);
+ /* We need a regular (non-UID) symbol here, therefore give a
+ prefix. */
+ var = gfc_create_var (TREE_TYPE (tmp), "atmp");
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
+ {
+ gfc_allocate_lang_decl (var);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
+ }
+ gfc_add_modify_loc (input_location, &block, var, tmp);
+ expr3 = var;
+ }
+ else
+ expr3 = se.expr;
+ /* Store what the expr3 is to be used for. */
+ e3_is = expr3 != NULL_TREE ?
+ (code->ext.alloc.arr_spec_from_expr3 ?
+ E3_DESC
+ : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
+ : E3_UNSET;
/* Figure how to get the _vtab entry. This also obtains the tree
expression for accessing the _len component, because only
@@ -5252,10 +5262,6 @@ gfc_trans_allocate (gfc_code * code)
if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))
&& (VAR_P (expr3) || !code->expr3->ref))
tmp = gfc_class_vptr_get (expr3);
- else if (expr3_tmp != NULL_TREE
- && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp))
- && (VAR_P (expr3_tmp) || !code->expr3->ref))
- tmp = gfc_class_vptr_get (expr3_tmp);
else
{
rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
@@ -5275,9 +5281,7 @@ gfc_trans_allocate (gfc_code * code)
{
/* Same like for retrieving the _vptr. */
if (expr3 != NULL_TREE && !code->expr3->ref)
- expr3_len = gfc_class_len_get (expr3);
- else if (expr3_tmp != NULL_TREE && !code->expr3->ref)
- expr3_len = gfc_class_len_get (expr3_tmp);
+ expr3_len = gfc_class_len_get (expr3);
else
{
rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
@@ -5338,8 +5342,11 @@ gfc_trans_allocate (gfc_code * code)
advantage is, that we get scalarizer support for free,
don't have to take care about scalar to array treatment and
will benefit of every enhancements gfc_trans_assignment ()
- gets. */
- if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
+ gets.
+ No need to check whether e3_is is E3_UNSET, because that is
+ done by expr3 != NULL_TREE. */
+ if (e3_is != E3_MOLD && expr3 != NULL_TREE
+ && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
{
/* Build a temporary symtree and symbol. Do not add it to
the current namespace to prevent accidently modifying
@@ -5391,6 +5398,12 @@ gfc_trans_allocate (gfc_code * code)
}
gcc_assert (expr3_esize);
expr3_esize = fold_convert (sizetype, expr3_esize);
+ if (e3_is == E3_MOLD)
+ {
+ /* The expr3 is no longer valid after this point. */
+ expr3 = NULL_TREE;
+ e3_is = E3_UNSET;
+ }
}
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
{
@@ -5490,7 +5503,9 @@ gfc_trans_allocate (gfc_code * code)
else
tmp = expr3_esize;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems, code->expr3))
+ label_finish, tmp, &nelems,
+ e3rhs ? e3rhs : code->expr3,
+ e3_is == E3_DESC ? expr3 : NULL_TREE))
{
/* A scalar or derived type. First compute the size to
allocate.
@@ -5696,11 +5711,15 @@ gfc_trans_allocate (gfc_code * code)
if (expr3 != NULL_TREE
&& ((POINTER_TYPE_P (TREE_TYPE (expr3))
&& TREE_CODE (expr3) != POINTER_PLUS_EXPR)
- || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))))
+ || (VAR_P (expr3) && GFC_CLASS_TYPE_P (
+ TREE_TYPE (expr3))))
&& code->expr3->ts.type == BT_CLASS
&& (expr->ts.type == BT_CLASS
|| expr->ts.type == BT_DERIVED))
{
+ /* copy_class_to_class can be used for class arrays, too.
+ It just needs to be ensured, that the decl_saved_descriptor
+ has a way to get to the vptr. */
tree to;
to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
tmp = gfc_copy_class_to_class (expr3, to,
@@ -5734,30 +5753,14 @@ gfc_trans_allocate (gfc_code * code)
if (dataref && dataref->u.c.component->as)
{
- int dim;
- gfc_expr *temp;
- gfc_ref *ref = dataref->next;
- ref->u.ar.type = AR_SECTION;
- /* We have to set up the array reference to give ranges
- in all dimensions and ensure that the end and stride
- are set so that the copy can be scalarized. */
- dim = 0;
- for (; dim < dataref->u.c.component->as->rank; dim++)
- {
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- if (ref->u.ar.end[dim] == NULL)
- {
- ref->u.ar.end[dim] = ref->u.ar.start[dim];
- temp = gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1);
- ref->u.ar.start[dim] = temp;
- }
- temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
- gfc_copy_expr (ref->u.ar.start[dim]));
- temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1),
- temp);
- }
+ gfc_array_spec *as = dataref->u.c.component->as;
+ gfc_free_ref_list (dataref->next);
+ dataref->next = NULL;
+ gfc_add_full_array_ref (last_arg->expr, as);
+ gfc_resolve_expr (last_arg->expr);
+ gcc_assert (last_arg->expr->ts.type == BT_CLASS
+ || last_arg->expr->ts.type == BT_DERIVED);
+ last_arg->expr->ts.type = BT_CLASS;
}
if (rhs->ts.type == BT_CLASS)
{
@@ -5839,7 +5842,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_expr_to_block (&block, tmp);
}
else if (code->expr3 && code->expr3->mold
- && code->expr3->ts.type == BT_CLASS)
+ && code->expr3->ts.type == BT_CLASS)
{
/* Since the _vptr has already been assigned to the allocate
object, we can use gfc_copy_class_to_class in its
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
index f7e0109..59d08d6 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
@@ -1,28 +1,110 @@
-! { dg-do compile }
+! { dg-do run }
!
! Contributed by Reinhold Bader
!
program assumed_shape_01
- use, intrinsic :: iso_c_binding
implicit none
- type, bind(c) :: cstruct
- integer(c_int) :: i
- real(c_float) :: r(2)
+ type :: cstruct
+ integer :: i
+ real :: r(2)
end type cstruct
- interface
- subroutine psub(this, that) bind(c, name='Psub')
- import :: c_float, cstruct
- real(c_float) :: this(:,:)
- type(cstruct) :: that(:)
- end subroutine psub
- end interface
-
- real(c_float) :: t(3,7)
+
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 (u(1)%i /= 4 .or. any(abs(u(1)%r(:) - [1.1,2.2]) > 1E-6)) call abort()
+ deallocate (u)
-! 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" }
- call psub(t, 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
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08
new file mode 100644
index 0000000..86df531
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08
@@ -0,0 +1,79 @@
+! { 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
+
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec
2015-05-29 12:41 ` Andre Vehreschild
@ 2015-05-30 4:23 ` Thomas Koenig
2015-06-02 16:52 ` Mikael Morin
1 sibling, 0 replies; 21+ messages in thread
From: Thomas Koenig @ 2015-05-30 4:23 UTC (permalink / raw)
To: Andre Vehreschild, Mikael Morin; +Cc: GCC-Patches-ML, GCC-Fortran-ML
Hi Andre,
just a couple of remarks.
You are adding significant new code to an existing
test case, allocate_with_source_3.f90. As discussed
previously, it would be better to put the new code
into an extra test case.
The following test case segfaults with your patch
with an "invalid free":
module foo
contains
integer function f()
f = 2
end function f
end module foo
program main
use foo
integer :: n
n = 42
block
real, dimension(0:n) :: a
real, dimension(:), allocatable :: c
call random_number(a)
allocate(c,source=a(:f()))
end block
end program main
You could also add
n = n - 1
allocate(c,source=a)
if (size(a,1) /= size(c,1)) call abort
to the test case above to make sure that changing a variable
that was used to declare an array bound does not lead to wrong
code.
Regards
Thomas
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec
2015-05-29 12:41 ` Andre Vehreschild
2015-05-30 4:23 ` Thomas Koenig
@ 2015-06-02 16:52 ` Mikael Morin
2015-06-03 15:25 ` Andre Vehreschild
1 sibling, 1 reply; 21+ messages in thread
From: Mikael Morin @ 2015-06-02 16:52 UTC (permalink / raw)
To: Andre Vehreschild; +Cc: GCC-Patches-ML, GCC-Fortran-ML
Hello Andre,
comments below (out of order, sorry).
Le 29/05/2015 13:46, Andre Vehreschild a écrit :
> Hi Mikael,
>
> comments inline below:
>
> On Thu, 28 May 2015 20:06:57 +0200
> Mikael Morin <mikael.morin@sfr.fr> wrote:
>
>> Le 28/05/2015 17:29, Andre Vehreschild a écrit :
>>> *************** resolve_allocate_expr (gfc_expr *e, gfc_
>>> *** 7103,7112 ****
>>> --- 7103,7123 ----
>>> if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
>>> || (dimension && ref2->u.ar.dimen == 0))
>>> {
>>> + /* F08:C633. */
>>> + if (code->expr3)
>>> + {
>>> + 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
>>> context of an ALLOCATE specification. */
>> I think we can be a little be more user friendly with the gfc_notify_std
>> error message.
>> Something like:
>> ALLOCATE without array spec at %L
>> ALLOCATE with array bounds determined from SOURCE or MOLD at %L
>
> I didn't want to mess with the error messages to prevent issues for
> translations. So how is the policy on this?
>
I'm not aware of any policy regarding translations.
With a message like:
fortran 2008: array specification required ...
I don't see how the user can understand that the array specification is
_not_ required with fortran 2008, regardless of translations.
I'm rather in favour of not having misleading diagnostic, even if
correctly translated.
--------
>>> *************** gfc_array_init_size (tree descriptor, in
>>> *** 5076,5085 ****
>>>
>>> /* Set upper bound. */
>>> gfc_init_se (&se, NULL);
>>> 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_rank_cst[n], se.expr);
>>> conv_ubound = se.expr;
>>> --- 5087,5111 ----
>>>
>>> /* Set upper bound. */
>>> gfc_init_se (&se, NULL);
>>> + if (expr3_desc != NULL_TREE)
>>> + {
>>> + /* Set 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]));
>>> + se.expr = fold_build2_loc (input_location, PLUS_EXPR,
>>> + gfc_array_index_type, tmp,
>>> + gfc_index_one_node);
>>> + }
>>> + 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_rank_cst[n], se.expr);
>>> conv_ubound = se.expr;
>> Your one-based-ness problem was here, wasn't it?
>
> Correct.
>
>> I would rather copy directly lbound and ubound from expr3_desc to
>> descriptor.
>
> It was that way in the previous version of the patch, which does *not* work any
> longer. When gfc_trans_allocate () is responsible for the creating a temporary
> variable for the source=-expression, then it does so using zero based
> expressions.
>
>> If the source has non-one-based bounds, the above would produce wrong
>> bounds.
>
> Counterexample? Note, the expr3_desc is guaranteed to be an artificial variable
> created by conv_expr_descriptor, aka zero-based.
>
here is a counterexample.
integer, dimension(:), allocatable :: a, b
allocate (a(0:3))
allocate (b, source = a)
print *, lbound(a, 1), ubound(a, 1)
print *, lbound(b, 1), ubound(b, 1)
end
output:
0 3
1 4
I think that if you set se.expr with
ubound with gfc_conv_descriptor_ubound_get(...) instead of what you do
above, and se.expr with gfc_conv_descriptor_lbound_get(...) instead of
gfc_index_one_node in the hunk before, it should work.
--------
> <snipp>
>
>>> *************** gfc_trans_allocate (gfc_code * code)
>>> *** 5229,5235 ****
>>> }
>>> else
>>> tmp = se.expr;
>>> ! if (!code->expr3->mold)
>>> expr3 = tmp;
>>> else
>>> expr3_tmp = tmp;
>>> --- 5240,5248 ----
>>> }
>>> else
>>> tmp = se.expr;
>>> ! if (code->ext.alloc.arr_spec_from_expr3)
>>> ! expr3_desc = tmp;
>>> ! else if (!code->expr3->mold)
>>> expr3 = tmp;
>>> else
>>> expr3_tmp = tmp;
>> Couldn't expr3 be reused?
>> We had code->expr3, expr3, expr3rhs, and now this is adding expr3_desc,
>> and (below) inexpr3. :-(
>
> Of course can we use just two variables for all expressions. I have removed the
> expr3_tmp, inexpr3 and expr3_desc and introduced a e3_is enumeration, which
> stores which kind the expr3 is, aka unset, source, mold, desc. This makes the
> code simpler at some places.
>
I have thought some more about the code not distinguishing source vs mold.
It seems to me that it makes sense to _not_ distinguish, and what you do
with e3_is == E3_MOLD seems bogus to me. For example:
> @@ -5391,6 +5398,12 @@ gfc_trans_allocate (gfc_code * code)
> }
> gcc_assert (expr3_esize);
> expr3_esize = fold_convert (sizetype, expr3_esize);
> + if (e3_is == E3_MOLD)
> + {
> + /* The expr3 is no longer valid after this point. */
> + expr3 = NULL_TREE;
> + e3_is = E3_UNSET;
> + }
> }
> else if (code->ext.alloc.ts.type != BT_UNKNOWN)
> {
You forget about the descriptor you have just created?!?
--------
About e3_is, I'm not very fond of it, and I think it can be replaced
using...
> + e3_is = expr3 != NULL_TREE ?
> + (code->ext.alloc.arr_spec_from_expr3 ?
> + E3_DESC
> + : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
> + : E3_UNSET;
>
... the conditions defining it above directly.
That is replace e3_is == E3_DESC with
code->ext.alloc.arr_spec_from_expr3, etc.
--------
> @@ -5035,6 +5036,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
>
> or_expr = boolean_false_node;
>
> + /* When expr3_desc is set, use its rank, because we want to allocate an
> + array with the array_spec coming from source=. */
> + if (expr3_desc != NULL_TREE)
> + rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (expr3_desc));
> +
> for (n = 0; n < rank; n++)
> {
> tree conv_lbound;
This overrides the rank passed as argument.
Instead of this, calculate the correct rank...
> @@ -5338,10 +5392,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
> overflow = integer_zero_node;
>
> 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,
... here. Wasn't it correct already by the way?
--------
> @@ -5174,25 +5174,26 @@ gfc_trans_allocate (gfc_code * code)
> {
> if (!code->expr3->mold
> || code->expr3->ts.type == BT_CHARACTER
> - || vtab_needed)
> + || vtab_needed
> + || code->ext.alloc.arr_spec_from_expr3)
> {
> /* Convert expr3 to a tree. */
> gfc_init_se (&se, NULL);
> - /* For all "simple" expression just get the descriptor or the
> - reference, respectively, depending on the rank of the expr. */
> - if (code->expr3->rank != 0)
> + /* For all "simple" expression just get the descriptor
> + or the reference, respectively, depending on the
> + rank of the expr. */
> + if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0)
Hum, why this change?
Are there cases where arr_spec_from_expr3 is set and code->expr3->rank == 0?
And do you really want to call gfc_conv_expr_descriptor in such a case?
> gfc_conv_expr_descriptor (&se, code->expr3);
> else
> gfc_conv_expr_reference (&se, code->expr3);
> - if (!code->expr3->mold)
> - expr3 = se.expr;
> - else
> - expr3_tmp = se.expr;
> + /* Create a temp variable only for component refs. */
> + temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF;
Why only component refs?
> expr3_len = se.string_length;
> gfc_add_block_to_block (&block, &se.pre);
> gfc_add_block_to_block (&post, &se.post);
> }
> - /* else expr3 = NULL_TREE set above. */
> + else
> + se.expr = NULL_TREE;
> }
> else
> {
--------
> diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
> index 9be8a42..3916836 100644
> --- a/gcc/fortran/trans-expr.c
> +++ b/gcc/fortran/trans-expr.c
> @@ -5328,7 +5328,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
> if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
> && e->ts.u.derived->attr.alloc_comp
> && !(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;
> tmp = build_fold_indirect_ref_loc (input_location,
You don't change it, so don't touch it.
> Attached is a new version of the patch. This one fails
> allocate_with_source_3.f90 on runtime, where I don't see the issue currently.
> May be you have some luck and time. If not I will investigate on Monday.
>
I haven't looked at it yet. Tomorrow maybe.
Thanks for your patience so far.
Mikael
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v6] [F08] ALLOCATE with SOURCE and no array-spec
2015-06-02 16:52 ` Mikael Morin
@ 2015-06-03 15:25 ` Andre Vehreschild
2015-06-05 12:04 ` [Patch, fortran, PR44672, v9] " Andre Vehreschild
0 siblings, 1 reply; 21+ messages in thread
From: Andre Vehreschild @ 2015-06-03 15:25 UTC (permalink / raw)
To: Mikael Morin; +Cc: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 1516 bytes --]
Hi,
no, I lost patience with this. Attached is the last version of this patch I will
provide. I have changed some things to fix the issues needed for
allocate_with_source_3.f90 (now called allocate_with_source_8.f08) to run. The
fix implies that source=[type_constructor(...)] generate a zero-bound array,
which is not correct according to the standard, but I can't do anything about
it you will like.
> I have thought some more about the code not distinguishing source vs mold.
> It seems to me that it makes sense to _not_ distinguish, and what you do
> with e3_is == E3_MOLD seems bogus to me. For example:
>
> > @@ -5391,6 +5398,12 @@ gfc_trans_allocate (gfc_code * code)
> > }
> > gcc_assert (expr3_esize);
> > expr3_esize = fold_convert (sizetype, expr3_esize);
> > + if (e3_is == E3_MOLD)
> > + {
> > + /* The expr3 is no longer valid after this point. */
> > + expr3 = NULL_TREE;
> > + e3_is = E3_UNSET;
> > + }
> > }
> > else if (code->ext.alloc.ts.type != BT_UNKNOWN)
> > {
> You forget about the descriptor you have just created?!?
+ e3_is = expr3 != NULL_TREE ?
+ (code->ext.alloc.arr_spec_from_expr3 ?
+ E3_DESC
+ : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
+ : E3_UNSET;
No, a E3_DESC is set before a E3_MOLD, therefore the reset in the chunk above
is not triggered.
I can't spend more resources on this. When you see the need of changes, you are
welcome to add them.
- Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr44672_8.patch --]
[-- Type: text/x-patch, Size: 26673 bytes --]
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 905d47c..211c781 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2396,6 +2396,9 @@ typedef struct gfc_code
{
gfc_typespec ts;
gfc_alloc *list;
+ /* Take the array specification from expr3 to allocate arrays
+ without an explicit array specification. */
+ unsigned arr_spec_from_expr3:1;
}
alloc;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e615cc6..315170a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6805,7 +6805,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
have a trailing array reference that gives the size of the array. */
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 codimension;
@@ -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
|| (dimension && ref2->u.ar.dimen == 0))
{
- gfc_error ("Array specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
+ /* F08:C633. */
+ if (code->expr3)
+ {
+ 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
- context of an ALLOCATE specification. */
+ context of an ALLOCATE specification. */
ar = &ref2->u.ar;
@@ -7125,7 +7136,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
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;
switch (ar->dimen_type[i])
@@ -7202,6 +7213,7 @@ failure:
return false;
}
+
static void
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)
{
+ bool arr_alloc_wo_spec = false;
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
{
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index c8fab45..9767e9d 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5005,7 +5005,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
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)
{
tree type;
tree tmp;
@@ -5020,7 +5021,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tree var;
stmtblock_t thenblock;
stmtblock_t elseblock;
- gfc_expr *ubound;
+ gfc_expr *ubound = NULL;
gfc_se se;
int n;
@@ -5035,6 +5036,11 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
or_expr = boolean_false_node;
+// /* When expr3_desc is set, use its rank, because we want to allocate an
+// array with the array_spec coming from source=. */
+// if (expr3_desc != NULL_TREE)
+// rank = GFC_TYPE_ARRAY_RANK (TREE_TYPE (expr3_desc));
+
for (n = 0; n < rank; n++)
{
tree conv_lbound;
@@ -5048,7 +5054,9 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set lower bound. */
gfc_init_se (&se, NULL);
- if (lower == NULL)
+ if (expr3_desc != NULL_TREE)
+ se.expr = gfc_conv_descriptor_lbound_get (expr3_desc, gfc_rank_cst[n]);
+ else if (lower == NULL)
se.expr = gfc_index_one_node;
else
{
@@ -5076,10 +5084,14 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set upper bound. */
gfc_init_se (&se, NULL);
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
-
+ if (expr3_desc != NULL_TREE)
+ 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_rank_cst[n], se.expr);
conv_ubound = se.expr;
@@ -5249,6 +5261,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
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
@@ -5256,7 +5295,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
tree errlen, tree label_finish, tree expr3_elem_size,
- tree *nelems, gfc_expr *expr3)
+ tree *nelems, gfc_expr *expr3, tree e3_arr_desc)
{
tree tmp;
tree pointer;
@@ -5274,21 +5313,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable, coarray, dimension;
+ bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
/* 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
- || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
- prev_ref = ref;
- ref = ref->next;
- }
+ /* F08:C633: Array shape from expr3. */
+ ref = expr3->ref;
- if (ref == NULL || ref->type != REF_ARRAY)
- return false;
+ /* Find the last reference in the chain. */
+ if (!retrieve_last_ref (&ref, &prev_ref))
+ return false;
+ alloc_w_e3_arr_spec = true;
+ }
if (!prev_ref)
{
@@ -5324,7 +5366,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
break;
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;
upper = ref->u.ar.as->upper;
@@ -5338,10 +5381,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
overflow = integer_zero_node;
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,
&se->pre, &set_descriptor_block, &overflow,
- expr3_elem_size, nelems, expr3);
+ expr3_elem_size, nelems, expr3, e3_arr_desc);
if (dimension)
{
@@ -7080,6 +7124,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
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)
{
/* Get a pointer to the new descriptor. */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 2155b58..6e5378f 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -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
se, which should contain an expression for the array descriptor. */
bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree,
- tree, tree *, gfc_expr *);
+ tree, tree *, gfc_expr *, tree);
/* 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 *,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 9be8a42..eb17f2c 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4567,6 +4567,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
int has_alternate_specifier = 0;
bool need_interface_mapping;
bool callee_alloc;
+ bool ulim_copy;
gfc_typespec ts;
gfc_charlen cl;
gfc_expr *e;
@@ -4575,6 +4576,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
gfc_component *comp = NULL;
int arglen;
+ unsigned int argc;
arglist = NULL;
retargs = NULL;
@@ -4630,10 +4632,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
base_object = NULL_TREE;
+ ulim_copy = formal == NULL && UNLIMITED_POLY (sym)
+ && strcmp ("_copy", comp->name) == 0;
/* Evaluate the arguments. */
- for (arg = args; arg != NULL;
- arg = arg->next, formal = formal ? formal->next : NULL)
+ for (arg = args, argc = 0; arg != NULL;
+ arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
{
e = arg->expr;
fsym = formal ? formal->sym : NULL;
@@ -4735,7 +4739,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_init_se (&parmse, se);
parm_kind = ELEMENTAL;
- if (fsym && fsym->attr.value)
+ if ((fsym && fsym->attr.value)
+ || (ulim_copy && (argc == 3 || argc == 4)))
gfc_conv_expr (&parmse, e);
else
gfc_conv_expr_reference (&parmse, e);
@@ -5328,7 +5333,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
&& e->ts.u.derived->attr.alloc_comp
&& !(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;
tmp = build_fold_indirect_ref_loc (input_location,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 81943b0..43bc34a 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5105,6 +5105,8 @@ gfc_trans_allocate (gfc_code * code)
the trees may be the NULL_TREE indicating that this is not
available for expr3's type. */
tree expr3, expr3_vptr, expr3_len, expr3_esize;
+ /* Classify what expr3 stores. */
+ enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
stmtblock_t block;
stmtblock_t post;
tree nelems;
@@ -5117,6 +5119,7 @@ gfc_trans_allocate (gfc_code * code)
stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+ e3_is = E3_UNSET;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -5156,10 +5159,7 @@ gfc_trans_allocate (gfc_code * code)
expression. */
if (code->expr3)
{
- bool vtab_needed = false;
- /* expr3_tmp gets the tree when code->expr3.mold is set, i.e.,
- the expression is only needed to get the _vptr, _len a.s.o. */
- tree expr3_tmp = NULL_TREE;
+ bool vtab_needed = false, temp_var_needed = false;
/* Figure whether we need the vtab from expr3. */
for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
@@ -5174,25 +5174,26 @@ gfc_trans_allocate (gfc_code * code)
{
if (!code->expr3->mold
|| code->expr3->ts.type == BT_CHARACTER
- || vtab_needed)
+ || vtab_needed
+ || code->ext.alloc.arr_spec_from_expr3)
{
/* Convert expr3 to a tree. */
gfc_init_se (&se, NULL);
- /* For all "simple" expression just get the descriptor or the
- reference, respectively, depending on the rank of the expr. */
- if (code->expr3->rank != 0)
+ /* For all "simple" expression just get the descriptor
+ or the reference, respectively, depending on the
+ rank of the expr. */
+ if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0)
gfc_conv_expr_descriptor (&se, code->expr3);
else
gfc_conv_expr_reference (&se, code->expr3);
- if (!code->expr3->mold)
- expr3 = se.expr;
- else
- expr3_tmp = se.expr;
+ /* Create a temp variable only for component refs. */
+ temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF;
expr3_len = se.string_length;
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
}
- /* else expr3 = NULL_TREE set above. */
+ else
+ se.expr = NULL_TREE;
}
else
{
@@ -5212,32 +5213,41 @@ gfc_trans_allocate (gfc_code * code)
code->expr3->ts,
false, true,
false, false);
+ temp_var_needed = !VAR_P (se.expr);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
- /* Prevent aliasing, i.e., se.expr may be already a
- variable declaration. */
- if (!VAR_P (se.expr))
- {
- tree var;
- tmp = build_fold_indirect_ref_loc (input_location,
- se.expr);
- /* We need a regular (non-UID) symbol here, therefore give a
- prefix. */
- var = gfc_create_var (TREE_TYPE (tmp), "atmp");
- gfc_add_modify_loc (input_location, &block, var, tmp);
- tmp = var;
- }
- else
- tmp = se.expr;
- if (!code->expr3->mold)
- expr3 = tmp;
- else
- expr3_tmp = tmp;
/* When he length of a char array is easily available
- here, fix it for future use. */
+ here, fix it for future use. */
if (se.string_length)
expr3_len = gfc_evaluate_now (se.string_length, &block);
}
+ /* Prevent aliasing, i.e., se.expr may be already a
+ variable declaration. */
+ if (se.expr != NULL_TREE && temp_var_needed)
+ {
+ tree var;
+ tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ?
+ se.expr
+ : build_fold_indirect_ref_loc (input_location, se.expr);
+ /* We need a regular (non-UID) symbol here, therefore give a
+ prefix. */
+ var = gfc_create_var (TREE_TYPE (tmp), "atmp");
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
+ {
+ gfc_allocate_lang_decl (var);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
+ }
+ gfc_add_modify_loc (input_location, &block, var, tmp);
+ expr3 = var;
+ }
+ else
+ expr3 = se.expr;
+ /* Store what the expr3 is to be used for. */
+ e3_is = expr3 != NULL_TREE ?
+ (code->ext.alloc.arr_spec_from_expr3 ?
+ E3_DESC
+ : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
+ : E3_UNSET;
/* Figure how to get the _vtab entry. This also obtains the tree
expression for accessing the _len component, because only
@@ -5252,10 +5262,6 @@ gfc_trans_allocate (gfc_code * code)
if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))
&& (VAR_P (expr3) || !code->expr3->ref))
tmp = gfc_class_vptr_get (expr3);
- else if (expr3_tmp != NULL_TREE
- && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp))
- && (VAR_P (expr3_tmp) || !code->expr3->ref))
- tmp = gfc_class_vptr_get (expr3_tmp);
else
{
rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
@@ -5275,9 +5281,7 @@ gfc_trans_allocate (gfc_code * code)
{
/* Same like for retrieving the _vptr. */
if (expr3 != NULL_TREE && !code->expr3->ref)
- expr3_len = gfc_class_len_get (expr3);
- else if (expr3_tmp != NULL_TREE && !code->expr3->ref)
- expr3_len = gfc_class_len_get (expr3_tmp);
+ expr3_len = gfc_class_len_get (expr3);
else
{
rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
@@ -5338,8 +5342,11 @@ gfc_trans_allocate (gfc_code * code)
advantage is, that we get scalarizer support for free,
don't have to take care about scalar to array treatment and
will benefit of every enhancements gfc_trans_assignment ()
- gets. */
- if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
+ gets.
+ No need to check whether e3_is is E3_UNSET, because that is
+ done by expr3 != NULL_TREE. */
+ if (e3_is != E3_MOLD && expr3 != NULL_TREE
+ && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
{
/* Build a temporary symtree and symbol. Do not add it to
the current namespace to prevent accidently modifying
@@ -5391,6 +5398,12 @@ gfc_trans_allocate (gfc_code * code)
}
gcc_assert (expr3_esize);
expr3_esize = fold_convert (sizetype, expr3_esize);
+ if (e3_is == E3_MOLD)
+ {
+ /* The expr3 is no longer valid after this point. */
+ expr3 = NULL_TREE;
+ e3_is = E3_UNSET;
+ }
}
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
{
@@ -5490,7 +5503,9 @@ gfc_trans_allocate (gfc_code * code)
else
tmp = expr3_esize;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems, code->expr3))
+ label_finish, tmp, &nelems,
+ e3rhs ? e3rhs : code->expr3,
+ e3_is == E3_DESC ? expr3 : NULL_TREE))
{
/* A scalar or derived type. First compute the size to
allocate.
@@ -5696,11 +5711,15 @@ gfc_trans_allocate (gfc_code * code)
if (expr3 != NULL_TREE
&& ((POINTER_TYPE_P (TREE_TYPE (expr3))
&& TREE_CODE (expr3) != POINTER_PLUS_EXPR)
- || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))))
+ || (VAR_P (expr3) && GFC_CLASS_TYPE_P (
+ TREE_TYPE (expr3))))
&& code->expr3->ts.type == BT_CLASS
&& (expr->ts.type == BT_CLASS
|| expr->ts.type == BT_DERIVED))
{
+ /* copy_class_to_class can be used for class arrays, too.
+ It just needs to be ensured, that the decl_saved_descriptor
+ has a way to get to the vptr. */
tree to;
to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
tmp = gfc_copy_class_to_class (expr3, to,
@@ -5734,30 +5753,14 @@ gfc_trans_allocate (gfc_code * code)
if (dataref && dataref->u.c.component->as)
{
- int dim;
- gfc_expr *temp;
- gfc_ref *ref = dataref->next;
- ref->u.ar.type = AR_SECTION;
- /* We have to set up the array reference to give ranges
- in all dimensions and ensure that the end and stride
- are set so that the copy can be scalarized. */
- dim = 0;
- for (; dim < dataref->u.c.component->as->rank; dim++)
- {
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- if (ref->u.ar.end[dim] == NULL)
- {
- ref->u.ar.end[dim] = ref->u.ar.start[dim];
- temp = gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1);
- ref->u.ar.start[dim] = temp;
- }
- temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
- gfc_copy_expr (ref->u.ar.start[dim]));
- temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1),
- temp);
- }
+ gfc_array_spec *as = dataref->u.c.component->as;
+ gfc_free_ref_list (dataref->next);
+ dataref->next = NULL;
+ gfc_add_full_array_ref (last_arg->expr, as);
+ gfc_resolve_expr (last_arg->expr);
+ gcc_assert (last_arg->expr->ts.type == BT_CLASS
+ || last_arg->expr->ts.type == BT_DERIVED);
+ last_arg->expr->ts.type = BT_CLASS;
}
if (rhs->ts.type == BT_CLASS)
{
@@ -5839,7 +5842,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_expr_to_block (&block, tmp);
}
else if (code->expr3 && code->expr3->mold
- && code->expr3->ts.type == BT_CLASS)
+ && code->expr3->ts.type == BT_CLASS)
{
/* Since the _vptr has already been assigned to the allocate
object, we can use gfc_copy_class_to_class in its
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08
new file mode 100644
index 0000000..86df531
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08
@@ -0,0 +1,79 @@
+! { 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
+
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08
new file mode 100644
index 0000000..185681e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08
@@ -0,0 +1,111 @@
+! { 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] )] )
+ print *, u(0)
+ if (any(u(:)%i /= 4) .or. any(abs(u(0)%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
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v9] [F08] ALLOCATE with SOURCE and no array-spec
2015-06-03 15:25 ` Andre Vehreschild
@ 2015-06-05 12:04 ` Andre Vehreschild
2015-06-09 5:36 ` Damian Rouson
2015-06-10 8:59 ` [Patch, fortran, PR44672, v10] " Andre Vehreschild
0 siblings, 2 replies; 21+ messages in thread
From: Andre Vehreschild @ 2015-06-05 12:04 UTC (permalink / raw)
To: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 762 bytes --]
Hi all,
attached is the most recent version of the patch. It addresses the standard
violation of allocate(foo, source=[bar(something)]), where foo after the
allocate was a zero-based array instead of a one-based. Furthermore does this
patch fix calling _vptr->_copy () routines, which come without an interface
specification leading to pass all arguments by reference. When copying a
deferred length string this is hazardous, because a __copy_character_* ()
routines third and fourth arguments are passed by value. This is fixed by
simply counting the actual arguments and using pass by value for third and
fourth to _copy routine.
Bootstraps and regtests ok on x86_64-linux-gnu/f21.
Ok for trunk?
- Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr44672_9.clog --]
[-- Type: application/octet-stream, Size: 1679 bytes --]
gcc/testsuite/ChangeLog:
2015-06-05 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-065-05 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.
[-- Attachment #3: pr44672_9.patch --]
[-- Type: text/x-patch, Size: 28734 bytes --]
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 905d47c..211c781 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2396,6 +2396,9 @@ typedef struct gfc_code
{
gfc_typespec ts;
gfc_alloc *list;
+ /* Take the array specification from expr3 to allocate arrays
+ without an explicit array specification. */
+ unsigned arr_spec_from_expr3:1;
}
alloc;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index e615cc6..315170a 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6805,7 +6805,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
have a trailing array reference that gives the size of the array. */
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 codimension;
@@ -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
|| (dimension && ref2->u.ar.dimen == 0))
{
- gfc_error ("Array specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
+ /* F08:C633. */
+ if (code->expr3)
+ {
+ 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
- context of an ALLOCATE specification. */
+ context of an ALLOCATE specification. */
ar = &ref2->u.ar;
@@ -7125,7 +7136,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
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;
switch (ar->dimen_type[i])
@@ -7202,6 +7213,7 @@ failure:
return false;
}
+
static void
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)
{
+ bool arr_alloc_wo_spec = false;
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
{
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index f552ff9..7494cf9 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5001,7 +5001,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
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 tmp;
@@ -5016,7 +5017,7 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tree var;
stmtblock_t thenblock;
stmtblock_t elseblock;
- gfc_expr *ubound;
+ gfc_expr *ubound = NULL;
gfc_se se;
int n;
@@ -5044,7 +5045,18 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set lower bound. */
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;
else
{
@@ -5072,10 +5084,34 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set upper bound. */
gfc_init_se (&se, NULL);
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
-
+ 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. 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]));
+ se.expr = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, tmp,
+ gfc_index_one_node);
+ }
+ 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_rank_cst[n], se.expr);
conv_ubound = se.expr;
@@ -5245,6 +5281,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
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
@@ -5252,7 +5315,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
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 pointer;
@@ -5270,21 +5334,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable, coarray, dimension;
+ bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
/* 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
- || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
- prev_ref = ref;
- ref = ref->next;
- }
+ /* F08:C633: Array shape from expr3. */
+ ref = expr3->ref;
- if (ref == NULL || ref->type != REF_ARRAY)
- return false;
+ /* Find the last reference in the chain. */
+ if (!retrieve_last_ref (&ref, &prev_ref))
+ return false;
+ alloc_w_e3_arr_spec = true;
+ }
if (!prev_ref)
{
@@ -5320,7 +5387,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
break;
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;
upper = ref->u.ar.as->upper;
@@ -5334,10 +5402,12 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
overflow = integer_zero_node;
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,
&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)
{
@@ -7076,6 +7146,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
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)
{
/* Get a pointer to the new descriptor. */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 2155b58..52f1c9a 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -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
se, which should contain an expression for the array descriptor. */
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. */
void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 5a704cf..f4c4708 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4564,6 +4564,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
int has_alternate_specifier = 0;
bool need_interface_mapping;
bool callee_alloc;
+ bool ulim_copy;
gfc_typespec ts;
gfc_charlen cl;
gfc_expr *e;
@@ -4572,6 +4573,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
gfc_component *comp = NULL;
int arglen;
+ unsigned int argc;
arglist = NULL;
retargs = NULL;
@@ -4627,10 +4629,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
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. */
- for (arg = args; arg != NULL;
- arg = arg->next, formal = formal ? formal->next : NULL)
+ for (arg = args, argc = 0; arg != NULL;
+ arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
{
e = arg->expr;
fsym = formal ? formal->sym : NULL;
@@ -4732,7 +4740,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_init_se (&parmse, se);
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 == 3 || argc == 4)))
gfc_conv_expr (&parmse, e);
else
gfc_conv_expr_reference (&parmse, e);
@@ -5325,7 +5340,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
&& e->ts.u.derived->attr.alloc_comp
&& !(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;
tmp = build_fold_indirect_ref_loc (input_location,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index e51cf15..04332f1 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5102,6 +5102,8 @@ gfc_trans_allocate (gfc_code * code)
the trees may be the NULL_TREE indicating that this is not
available for expr3's type. */
tree expr3, expr3_vptr, expr3_len, expr3_esize;
+ /* Classify what expr3 stores. */
+ enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
stmtblock_t block;
stmtblock_t post;
tree nelems;
@@ -5114,6 +5116,7 @@ gfc_trans_allocate (gfc_code * code)
stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+ e3_is = E3_UNSET;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -5153,10 +5156,7 @@ gfc_trans_allocate (gfc_code * code)
expression. */
if (code->expr3)
{
- bool vtab_needed = false;
- /* expr3_tmp gets the tree when code->expr3.mold is set, i.e.,
- the expression is only needed to get the _vptr, _len a.s.o. */
- tree expr3_tmp = NULL_TREE;
+ bool vtab_needed = false, temp_var_needed = false;
/* Figure whether we need the vtab from expr3. */
for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
@@ -5171,25 +5171,28 @@ gfc_trans_allocate (gfc_code * code)
{
if (!code->expr3->mold
|| code->expr3->ts.type == BT_CHARACTER
- || vtab_needed)
+ || vtab_needed
+ || code->ext.alloc.arr_spec_from_expr3)
{
/* Convert expr3 to a tree. */
gfc_init_se (&se, NULL);
- /* For all "simple" expression just get the descriptor or the
- reference, respectively, depending on the rank of the expr. */
- if (code->expr3->rank != 0)
+ /* For all "simple" expression just get the descriptor
+ or the reference, respectively, depending on the
+ rank of the expr. */
+ if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0)
gfc_conv_expr_descriptor (&se, code->expr3);
else
gfc_conv_expr_reference (&se, code->expr3);
- if (!code->expr3->mold)
- expr3 = se.expr;
- else
- expr3_tmp = se.expr;
+ /* Create a temp variable only for component refs to prevent
+ having to go the full deref-chain each time and to simplfy
+ computation of array properties. */
+ temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF;
expr3_len = se.string_length;
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
}
- /* else expr3 = NULL_TREE set above. */
+ else
+ se.expr = NULL_TREE;
}
else
{
@@ -5209,32 +5212,41 @@ gfc_trans_allocate (gfc_code * code)
code->expr3->ts,
false, true,
false, false);
+ temp_var_needed = !VAR_P (se.expr);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
- /* Prevent aliasing, i.e., se.expr may be already a
- variable declaration. */
- if (!VAR_P (se.expr))
- {
- tree var;
- tmp = build_fold_indirect_ref_loc (input_location,
- se.expr);
- /* We need a regular (non-UID) symbol here, therefore give a
- prefix. */
- var = gfc_create_var (TREE_TYPE (tmp), "atmp");
- gfc_add_modify_loc (input_location, &block, var, tmp);
- tmp = var;
- }
- else
- tmp = se.expr;
- if (!code->expr3->mold)
- expr3 = tmp;
- else
- expr3_tmp = tmp;
/* When he length of a char array is easily available
- here, fix it for future use. */
+ here, fix it for future use. */
if (se.string_length)
expr3_len = gfc_evaluate_now (se.string_length, &block);
}
+ /* Prevent aliasing, i.e., se.expr may be already a
+ variable declaration. */
+ if (se.expr != NULL_TREE && temp_var_needed)
+ {
+ tree var;
+ tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ?
+ se.expr
+ : build_fold_indirect_ref_loc (input_location, se.expr);
+ /* We need a regular (non-UID) symbol here, therefore give a
+ prefix. */
+ var = gfc_create_var (TREE_TYPE (tmp), "atmp");
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
+ {
+ gfc_allocate_lang_decl (var);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
+ }
+ gfc_add_modify_loc (input_location, &block, var, tmp);
+ expr3 = var;
+ }
+ else
+ expr3 = se.expr;
+ /* Store what the expr3 is to be used for. */
+ e3_is = expr3 != NULL_TREE ?
+ (code->ext.alloc.arr_spec_from_expr3 ?
+ E3_DESC
+ : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
+ : E3_UNSET;
/* Figure how to get the _vtab entry. This also obtains the tree
expression for accessing the _len component, because only
@@ -5249,10 +5261,6 @@ gfc_trans_allocate (gfc_code * code)
if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))
&& (VAR_P (expr3) || !code->expr3->ref))
tmp = gfc_class_vptr_get (expr3);
- else if (expr3_tmp != NULL_TREE
- && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp))
- && (VAR_P (expr3_tmp) || !code->expr3->ref))
- tmp = gfc_class_vptr_get (expr3_tmp);
else
{
rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
@@ -5272,9 +5280,7 @@ gfc_trans_allocate (gfc_code * code)
{
/* Same like for retrieving the _vptr. */
if (expr3 != NULL_TREE && !code->expr3->ref)
- expr3_len = gfc_class_len_get (expr3);
- else if (expr3_tmp != NULL_TREE && !code->expr3->ref)
- expr3_len = gfc_class_len_get (expr3_tmp);
+ expr3_len = gfc_class_len_get (expr3);
else
{
rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
@@ -5335,8 +5341,11 @@ gfc_trans_allocate (gfc_code * code)
advantage is, that we get scalarizer support for free,
don't have to take care about scalar to array treatment and
will benefit of every enhancements gfc_trans_assignment ()
- gets. */
- if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
+ gets.
+ No need to check whether e3_is is E3_UNSET, because that is
+ done by expr3 != NULL_TREE. */
+ if (e3_is != E3_MOLD && expr3 != NULL_TREE
+ && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
{
/* Build a temporary symtree and symbol. Do not add it to
the current namespace to prevent accidently modifying
@@ -5388,6 +5397,12 @@ gfc_trans_allocate (gfc_code * code)
}
gcc_assert (expr3_esize);
expr3_esize = fold_convert (sizetype, expr3_esize);
+ if (e3_is == E3_MOLD)
+ {
+ /* The expr3 is no longer valid after this point. */
+ expr3 = NULL_TREE;
+ e3_is = E3_UNSET;
+ }
}
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
{
@@ -5487,7 +5502,11 @@ gfc_trans_allocate (gfc_code * code)
else
tmp = expr3_esize;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems, code->expr3))
+ label_finish, tmp, &nelems,
+ e3rhs ? e3rhs : code->expr3,
+ e3_is == E3_DESC ? expr3 : NULL_TREE,
+ code->expr3 != NULL
+ && code->expr3->expr_type == EXPR_ARRAY))
{
/* A scalar or derived type. First compute the size to
allocate.
@@ -5693,11 +5712,15 @@ gfc_trans_allocate (gfc_code * code)
if (expr3 != NULL_TREE
&& ((POINTER_TYPE_P (TREE_TYPE (expr3))
&& TREE_CODE (expr3) != POINTER_PLUS_EXPR)
- || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))))
+ || (VAR_P (expr3) && GFC_CLASS_TYPE_P (
+ TREE_TYPE (expr3))))
&& code->expr3->ts.type == BT_CLASS
&& (expr->ts.type == BT_CLASS
|| expr->ts.type == BT_DERIVED))
{
+ /* copy_class_to_class can be used for class arrays, too.
+ It just needs to be ensured, that the decl_saved_descriptor
+ has a way to get to the vptr. */
tree to;
to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
tmp = gfc_copy_class_to_class (expr3, to,
@@ -5731,30 +5754,14 @@ gfc_trans_allocate (gfc_code * code)
if (dataref && dataref->u.c.component->as)
{
- int dim;
- gfc_expr *temp;
- gfc_ref *ref = dataref->next;
- ref->u.ar.type = AR_SECTION;
- /* We have to set up the array reference to give ranges
- in all dimensions and ensure that the end and stride
- are set so that the copy can be scalarized. */
- dim = 0;
- for (; dim < dataref->u.c.component->as->rank; dim++)
- {
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- if (ref->u.ar.end[dim] == NULL)
- {
- ref->u.ar.end[dim] = ref->u.ar.start[dim];
- temp = gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1);
- ref->u.ar.start[dim] = temp;
- }
- temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
- gfc_copy_expr (ref->u.ar.start[dim]));
- temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1),
- temp);
- }
+ gfc_array_spec *as = dataref->u.c.component->as;
+ gfc_free_ref_list (dataref->next);
+ dataref->next = NULL;
+ gfc_add_full_array_ref (last_arg->expr, as);
+ gfc_resolve_expr (last_arg->expr);
+ gcc_assert (last_arg->expr->ts.type == BT_CLASS
+ || last_arg->expr->ts.type == BT_DERIVED);
+ last_arg->expr->ts.type = BT_CLASS;
}
if (rhs->ts.type == BT_CLASS)
{
@@ -5836,7 +5843,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_expr_to_block (&block, tmp);
}
else if (code->expr3 && code->expr3->mold
- && code->expr3->ts.type == BT_CLASS)
+ && code->expr3->ts.type == BT_CLASS)
{
/* Since the _vptr has already been assigned to the allocate
object, we can use gfc_copy_class_to_class in its
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
index f7e0109..93f6edb 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
@@ -21,7 +21,7 @@ program assumed_shape_01
type(cstruct), pointer :: u(:)
! 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)
deallocate (u)
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08
new file mode 100644
index 0000000..86df531
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08
@@ -0,0 +1,79 @@
+! { 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
+
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08
new file mode 100644
index 0000000..b331866
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08
@@ -0,0 +1,110 @@
+! { 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
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v9] [F08] ALLOCATE with SOURCE and no array-spec
2015-06-05 12:04 ` [Patch, fortran, PR44672, v9] " Andre Vehreschild
@ 2015-06-09 5:36 ` Damian Rouson
2015-06-10 8:59 ` [Patch, fortran, PR44672, v10] " Andre Vehreschild
1 sibling, 0 replies; 21+ messages in thread
From: Damian Rouson @ 2015-06-09 5:36 UTC (permalink / raw)
To: Andre Vehreschild; +Cc: GCC-Patches-ML, GCC-Fortran-ML, Clune Tom
All,
I sincerely hope this patch will hit the trunk soon. There are 9 users on the cc list for this bug so it is clearly of considerable user interest. I was recently informed that the following three-line program does not compile:
$ cat source-allocation.f90
integer, allocatable :: x(:)
allocate(x,source=[1])
end
$ gfortran source-allocation.f90
source-allocation.f90:2:11:
allocate(x,source=[1])
1
Error: Array specification required in ALLOCATE statement at (1)
$ gfortran --version
GNU Fortran (GCC) 6.0.0 20150607 (experimental)
I was heartened to find out from the initial bug report that it’s a Fortran 2008 feature, which makes the behavior somewhat understandable, but it’s a fairly simple use case that I would imagine will be used widely. FYI, the above three-line program compiles and executes cleanly with the NAG, Cray, Intel, and Portland Group compilers.
________________________________
Damian Rouson, Ph.D., P.E.
Founder & President, Sourcery, Inc.
510-600-2992 (mobile)
http://www.sourceryinstitute.org
http://rouson.youcanbook.me
> On Jun 5, 2015, at 4:04 AM, Andre Vehreschild <vehre@gmx.de> wrote:
>
> Hi all,
>
> attached is the most recent version of the patch. It addresses the standard
> violation of allocate(foo, source=[bar(something)]), where foo after the
> allocate was a zero-based array instead of a one-based. Furthermore does this
> patch fix calling _vptr->_copy () routines, which come without an interface
> specification leading to pass all arguments by reference. When copying a
> deferred length string this is hazardous, because a __copy_character_* ()
> routines third and fourth arguments are passed by value. This is fixed by
> simply counting the actual arguments and using pass by value for third and
> fourth to _copy routine.
>
> Bootstraps and regtests ok on x86_64-linux-gnu/f21.
>
> Ok for trunk?
>
> - Andre
> --
> Andre Vehreschild * Email: vehre ad gmx dot de
> <pr44672_9.clog><pr44672_9.patch>
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v10] [F08] ALLOCATE with SOURCE and no array-spec
2015-06-05 12:04 ` [Patch, fortran, PR44672, v9] " Andre Vehreschild
2015-06-09 5:36 ` Damian Rouson
@ 2015-06-10 8:59 ` Andre Vehreschild
2015-06-11 22:05 ` Thomas Koenig
1 sibling, 1 reply; 21+ messages in thread
From: Andre Vehreschild @ 2015-06-10 8:59 UTC (permalink / raw)
To: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 1314 bytes --]
Hi all,
please find attached an updated version of the patch. This patch simplifies
some cases and ensures more straight line code. Furthermore was a bug in the
interfacing routine for the _vptr->_copy() routine removed, where not the third
and fourth arguments translated to be passed be value but the fourth and fifth
(cs start counting at zero...).
Bootstraps and regtests fine on x86_64-linux-gnu/f21.
Ok for trunk?
Regards,
Andre
On Fri, 5 Jun 2015 13:04:01 +0200
Andre Vehreschild <vehre@gmx.de> wrote:
> Hi all,
>
> attached is the most recent version of the patch. It addresses the standard
> violation of allocate(foo, source=[bar(something)]), where foo after the
> allocate was a zero-based array instead of a one-based. Furthermore does this
> patch fix calling _vptr->_copy () routines, which come without an interface
> specification leading to pass all arguments by reference. When copying a
> deferred length string this is hazardous, because a __copy_character_* ()
> routines third and fourth arguments are passed by value. This is fixed by
> simply counting the actual arguments and using pass by value for third and
> fourth to _copy routine.
>
> Bootstraps and regtests ok on x86_64-linux-gnu/f21.
>
> Ok for trunk?
>
> - Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: pr44672_10.clog --]
[-- Type: application/octet-stream, Size: 1679 bytes --]
gcc/testsuite/ChangeLog:
2015-06-10 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-065-10 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.
[-- Attachment #3: pr44672_10.patch --]
[-- Type: text/x-patch, Size: 29306 bytes --]
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 8e4ca42..4b07ddb 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2395,6 +2395,9 @@ typedef struct gfc_code
{
gfc_typespec ts;
gfc_alloc *list;
+ /* Take the array specification from expr3 to allocate arrays
+ without an explicit array specification. */
+ unsigned arr_spec_from_expr3:1;
}
alloc;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 52dc109..f365e8f 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -6805,7 +6805,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
have a trailing array reference that gives the size of the array. */
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 codimension;
@@ -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
|| (dimension && ref2->u.ar.dimen == 0))
{
- gfc_error ("Array specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
+ /* F08:C633. */
+ if (code->expr3)
+ {
+ 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
- context of an ALLOCATE specification. */
+ context of an ALLOCATE specification. */
ar = &ref2->u.ar;
@@ -7125,7 +7136,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
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;
switch (ar->dimen_type[i])
@@ -7202,6 +7213,7 @@ failure:
return false;
}
+
static void
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)
{
+ bool arr_alloc_wo_spec = false;
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
{
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 5ea9aec..e9174ae 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4998,7 +4998,8 @@ static tree
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
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 tmp;
@@ -5041,7 +5042,18 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set lower bound. */
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;
else
{
@@ -5069,10 +5081,35 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
/* Set upper bound. */
gfc_init_se (&se, NULL);
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
-
+ 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. 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_rank_cst[n], se.expr);
conv_ubound = se.expr;
@@ -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
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
@@ -5249,7 +5313,8 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
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 pointer;
@@ -5267,21 +5332,24 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable, coarray, dimension;
+ bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
/* 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
- || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
- prev_ref = ref;
- ref = ref->next;
- }
+ /* F08:C633: Array shape from expr3. */
+ ref = expr3->ref;
- if (ref == NULL || ref->type != REF_ARRAY)
- return false;
+ /* Find the last reference in the chain. */
+ if (!retrieve_last_ref (&ref, &prev_ref))
+ return false;
+ alloc_w_e3_arr_spec = true;
+ }
if (!prev_ref)
{
@@ -5317,7 +5385,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
break;
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;
upper = ref->u.ar.as->upper;
@@ -5331,10 +5400,12 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
overflow = integer_zero_node;
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,
&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)
{
@@ -7073,6 +7144,16 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
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)
{
/* Get a pointer to the new descriptor. */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 2155b58..52f1c9a 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -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
se, which should contain an expression for the array descriptor. */
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. */
void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 1c880bc..e75577e 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -4561,6 +4561,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
int has_alternate_specifier = 0;
bool need_interface_mapping;
bool callee_alloc;
+ bool ulim_copy;
gfc_typespec ts;
gfc_charlen cl;
gfc_expr *e;
@@ -4569,6 +4570,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
gfc_component *comp = NULL;
int arglen;
+ unsigned int argc;
arglist = NULL;
retargs = NULL;
@@ -4624,10 +4626,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
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. */
- for (arg = args; arg != NULL;
- arg = arg->next, formal = formal ? formal->next : NULL)
+ for (arg = args, argc = 0; arg != NULL;
+ arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
{
e = arg->expr;
fsym = formal ? formal->sym : NULL;
@@ -4729,7 +4737,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_init_se (&parmse, se);
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);
else
gfc_conv_expr_reference (&parmse, e);
@@ -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)
&& e->ts.u.derived->attr.alloc_comp
&& !(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;
tmp = build_fold_indirect_ref_loc (input_location,
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index a7f39d0..0277d42 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5098,6 +5098,8 @@ gfc_trans_allocate (gfc_code * code)
the trees may be the NULL_TREE indicating that this is not
available for expr3's type. */
tree expr3, expr3_vptr, expr3_len, expr3_esize;
+ /* Classify what expr3 stores. */
+ enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
stmtblock_t block;
stmtblock_t post;
tree nelems;
@@ -5110,6 +5112,7 @@ gfc_trans_allocate (gfc_code * code)
stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+ e3_is = E3_UNSET;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -5149,16 +5152,14 @@ gfc_trans_allocate (gfc_code * code)
expression. */
if (code->expr3)
{
- bool vtab_needed = false;
- /* expr3_tmp gets the tree when code->expr3.mold is set, i.e.,
- the expression is only needed to get the _vptr, _len a.s.o. */
- tree expr3_tmp = NULL_TREE;
+ bool vtab_needed = false, temp_var_needed = false;
/* Figure whether we need the vtab from expr3. */
for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
al = al->next)
vtab_needed = (al->expr->ts.type == BT_CLASS);
+ gfc_init_se (&se, NULL);
/* When expr3 is a variable, i.e., a very simple expression,
then convert it once here. */
if (code->expr3->expr_type == EXPR_VARIABLE
@@ -5167,31 +5168,25 @@ gfc_trans_allocate (gfc_code * code)
{
if (!code->expr3->mold
|| code->expr3->ts.type == BT_CHARACTER
- || vtab_needed)
+ || vtab_needed
+ || code->ext.alloc.arr_spec_from_expr3)
{
- /* Convert expr3 to a tree. */
- gfc_init_se (&se, NULL);
- /* For all "simple" expression just get the descriptor or the
- reference, respectively, depending on the rank of the expr. */
- if (code->expr3->rank != 0)
+ /* Convert expr3 to a tree. For all "simple" expression just
+ get the descriptor or the reference, respectively, depending
+ on the rank of the expr. */
+ if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0)
gfc_conv_expr_descriptor (&se, code->expr3);
else
gfc_conv_expr_reference (&se, code->expr3);
- if (!code->expr3->mold)
- expr3 = se.expr;
- else
- expr3_tmp = se.expr;
- expr3_len = se.string_length;
- gfc_add_block_to_block (&block, &se.pre);
- gfc_add_block_to_block (&post, &se.post);
+ /* Create a temp variable only for component refs to prevent
+ having to go through the full deref-chain each time and to
+ simplfy computation of array properties. */
+ temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF;
}
- /* else expr3 = NULL_TREE set above. */
}
else
{
- /* In all other cases evaluate the expr3 and create a
- temporary. */
- gfc_init_se (&se, NULL);
+ /* In all other cases evaluate the expr3. */
symbol_attribute attr;
/* Get the descriptor for all arrays, that are not allocatable or
pointer, because the latter are descriptors already. */
@@ -5205,32 +5200,43 @@ gfc_trans_allocate (gfc_code * code)
code->expr3->ts,
false, true,
false, false);
- gfc_add_block_to_block (&block, &se.pre);
- gfc_add_block_to_block (&post, &se.post);
- /* Prevent aliasing, i.e., se.expr may be already a
- variable declaration. */
- if (!VAR_P (se.expr))
+ temp_var_needed = !VAR_P (se.expr);
+ }
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_block_to_block (&post, &se.post);
+ /* Prevent aliasing, i.e., se.expr may be already a
+ variable declaration. */
+ if (se.expr != NULL_TREE && temp_var_needed)
+ {
+ tree var;
+ tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ?
+ se.expr
+ : build_fold_indirect_ref_loc (input_location, se.expr);
+ /* We need a regular (non-UID) symbol here, therefore give a
+ prefix. */
+ var = gfc_create_var (TREE_TYPE (tmp), "source");
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
{
- tree var;
- tmp = build_fold_indirect_ref_loc (input_location,
- se.expr);
- /* We need a regular (non-UID) symbol here, therefore give a
- prefix. */
- var = gfc_create_var (TREE_TYPE (tmp), "atmp");
- gfc_add_modify_loc (input_location, &block, var, tmp);
- tmp = var;
+ gfc_allocate_lang_decl (var);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
}
- else
- tmp = se.expr;
- if (!code->expr3->mold)
- expr3 = tmp;
- else
- expr3_tmp = tmp;
- /* When he length of a char array is easily available
- here, fix it for future use. */
+ gfc_add_modify_loc (input_location, &block, var, tmp);
+ expr3 = var;
if (se.string_length)
+ /* Evaluate it assuming that it also is complicated like expr3. */
expr3_len = gfc_evaluate_now (se.string_length, &block);
}
+ else
+ {
+ expr3 = se.expr;
+ expr3_len = se.string_length;
+ }
+ /* Store what the expr3 is to be used for. */
+ e3_is = expr3 != NULL_TREE ?
+ (code->ext.alloc.arr_spec_from_expr3 ?
+ E3_DESC
+ : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
+ : E3_UNSET;
/* Figure how to get the _vtab entry. This also obtains the tree
expression for accessing the _len component, because only
@@ -5245,10 +5251,6 @@ gfc_trans_allocate (gfc_code * code)
if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))
&& (VAR_P (expr3) || !code->expr3->ref))
tmp = gfc_class_vptr_get (expr3);
- else if (expr3_tmp != NULL_TREE
- && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp))
- && (VAR_P (expr3_tmp) || !code->expr3->ref))
- tmp = gfc_class_vptr_get (expr3_tmp);
else
{
rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
@@ -5268,9 +5270,7 @@ gfc_trans_allocate (gfc_code * code)
{
/* Same like for retrieving the _vptr. */
if (expr3 != NULL_TREE && !code->expr3->ref)
- expr3_len = gfc_class_len_get (expr3);
- else if (expr3_tmp != NULL_TREE && !code->expr3->ref)
- expr3_len = gfc_class_len_get (expr3_tmp);
+ expr3_len = gfc_class_len_get (expr3);
else
{
rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
@@ -5331,8 +5331,11 @@ gfc_trans_allocate (gfc_code * code)
advantage is, that we get scalarizer support for free,
don't have to take care about scalar to array treatment and
will benefit of every enhancements gfc_trans_assignment ()
- gets. */
- if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
+ gets.
+ No need to check whether e3_is is E3_UNSET, because that is
+ done by expr3 != NULL_TREE. */
+ if (e3_is != E3_MOLD && expr3 != NULL_TREE
+ && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
{
/* Build a temporary symtree and symbol. Do not add it to
the current namespace to prevent accidently modifying
@@ -5384,6 +5387,12 @@ gfc_trans_allocate (gfc_code * code)
}
gcc_assert (expr3_esize);
expr3_esize = fold_convert (sizetype, expr3_esize);
+ if (e3_is == E3_MOLD)
+ {
+ /* The expr3 is no longer valid after this point. */
+ expr3 = NULL_TREE;
+ e3_is = E3_UNSET;
+ }
}
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
{
@@ -5483,7 +5492,11 @@ gfc_trans_allocate (gfc_code * code)
else
tmp = expr3_esize;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems, code->expr3))
+ label_finish, tmp, &nelems,
+ e3rhs ? e3rhs : code->expr3,
+ e3_is == E3_DESC ? expr3 : NULL_TREE,
+ code->expr3 != NULL && e3_is == E3_DESC
+ && code->expr3->expr_type == EXPR_ARRAY))
{
/* A scalar or derived type. First compute the size to
allocate.
@@ -5689,11 +5702,15 @@ gfc_trans_allocate (gfc_code * code)
if (expr3 != NULL_TREE
&& ((POINTER_TYPE_P (TREE_TYPE (expr3))
&& TREE_CODE (expr3) != POINTER_PLUS_EXPR)
- || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))))
+ || (VAR_P (expr3) && GFC_CLASS_TYPE_P (
+ TREE_TYPE (expr3))))
&& code->expr3->ts.type == BT_CLASS
&& (expr->ts.type == BT_CLASS
|| expr->ts.type == BT_DERIVED))
{
+ /* copy_class_to_class can be used for class arrays, too.
+ It just needs to be ensured, that the decl_saved_descriptor
+ has a way to get to the vptr. */
tree to;
to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
tmp = gfc_copy_class_to_class (expr3, to,
@@ -5727,30 +5744,14 @@ gfc_trans_allocate (gfc_code * code)
if (dataref && dataref->u.c.component->as)
{
- int dim;
- gfc_expr *temp;
- gfc_ref *ref = dataref->next;
- ref->u.ar.type = AR_SECTION;
- /* We have to set up the array reference to give ranges
- in all dimensions and ensure that the end and stride
- are set so that the copy can be scalarized. */
- dim = 0;
- for (; dim < dataref->u.c.component->as->rank; dim++)
- {
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- if (ref->u.ar.end[dim] == NULL)
- {
- ref->u.ar.end[dim] = ref->u.ar.start[dim];
- temp = gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1);
- ref->u.ar.start[dim] = temp;
- }
- temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
- gfc_copy_expr (ref->u.ar.start[dim]));
- temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1),
- temp);
- }
+ gfc_array_spec *as = dataref->u.c.component->as;
+ gfc_free_ref_list (dataref->next);
+ dataref->next = NULL;
+ gfc_add_full_array_ref (last_arg->expr, as);
+ gfc_resolve_expr (last_arg->expr);
+ gcc_assert (last_arg->expr->ts.type == BT_CLASS
+ || last_arg->expr->ts.type == BT_DERIVED);
+ last_arg->expr->ts.type = BT_CLASS;
}
if (rhs->ts.type == BT_CLASS)
{
@@ -5832,7 +5833,7 @@ gfc_trans_allocate (gfc_code * code)
gfc_add_expr_to_block (&block, tmp);
}
else if (code->expr3 && code->expr3->mold
- && code->expr3->ts.type == BT_CLASS)
+ && code->expr3->ts.type == BT_CLASS)
{
/* Since the _vptr has already been assigned to the allocate
object, we can use gfc_copy_class_to_class in its
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
index f7e0109..93f6edb 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
@@ -21,7 +21,7 @@ program assumed_shape_01
type(cstruct), pointer :: u(:)
! 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)
deallocate (u)
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08
new file mode 100644
index 0000000..86df531
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_7.f08
@@ -0,0 +1,79 @@
+! { 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
+
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 b/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08
new file mode 100644
index 0000000..b331866
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_8.f08
@@ -0,0 +1,110 @@
+! { 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
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v10] [F08] ALLOCATE with SOURCE and no array-spec
2015-06-10 8:59 ` [Patch, fortran, PR44672, v10] " Andre Vehreschild
@ 2015-06-11 22:05 ` Thomas Koenig
2015-06-12 8:00 ` Andre Vehreschild
2015-06-15 10:43 ` Andre Vehreschild
0 siblings, 2 replies; 21+ messages in thread
From: Thomas Koenig @ 2015-06-11 22:05 UTC (permalink / raw)
To: Andre Vehreschild, GCC-Patches-ML, GCC-Fortran-ML
Hi Andre,
> please find attached an updated version of the patch. This patch simplifies
> some cases and ensures more straight line code. Furthermore was a bug in the
> interfacing routine for the _vptr->_copy() routine removed, where not the third
> and fourth arguments translated to be passed be value but the fourth and fifth
> (cs start counting at zero...).
>
> Bootstraps and regtests fine on x86_64-linux-gnu/f21.
>
> Ok for trunk?
Following the discussions, and looking through the patch, I would say
this patch is in pretty good shape (and quite impressive, too).
My vote would be to commit as is, unless something important comes up,
and fix smaller problems and possible corner cases afterwards, if any
exist. However, I am not really deep into these aspects of the
compiler, and I would still like to leave some time for others to
comment if they think this is appropriate.
So, OK to commit in two days unless there are objections.
Thanks for the patch!
Thomas
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v10] [F08] ALLOCATE with SOURCE and no array-spec
2015-06-11 22:05 ` Thomas Koenig
@ 2015-06-12 8:00 ` Andre Vehreschild
2015-06-15 10:43 ` Andre Vehreschild
1 sibling, 0 replies; 21+ messages in thread
From: Andre Vehreschild @ 2015-06-12 8:00 UTC (permalink / raw)
To: Thomas Koenig; +Cc: GCC-Patches-ML, GCC-Fortran-ML
Hi Thomas,
thanks for the review and valuing my effort.
I am on travel over the weekend, i.e., I will commit the job earliest on Monday
giving objections a bit more time.
Regards and thanks,
Andre
On Thu, 11 Jun 2015 23:59:48 +0200
Thomas Koenig <tkoenig@netcologne.de> wrote:
> Hi Andre,
>
> > please find attached an updated version of the patch. This patch simplifies
> > some cases and ensures more straight line code. Furthermore was a bug in the
> > interfacing routine for the _vptr->_copy() routine removed, where not the
> > third and fourth arguments translated to be passed be value but the fourth
> > and fifth (cs start counting at zero...).
> >
> > Bootstraps and regtests fine on x86_64-linux-gnu/f21.
> >
> > Ok for trunk?
>
> Following the discussions, and looking through the patch, I would say
> this patch is in pretty good shape (and quite impressive, too).
>
> My vote would be to commit as is, unless something important comes up,
> and fix smaller problems and possible corner cases afterwards, if any
> exist. However, I am not really deep into these aspects of the
> compiler, and I would still like to leave some time for others to
> comment if they think this is appropriate.
>
> So, OK to commit in two days unless there are objections.
>
> Thanks for the patch!
>
> Thomas
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
^ permalink raw reply [flat|nested] 21+ messages in thread
* Re: [Patch, fortran, PR44672, v10] [F08] ALLOCATE with SOURCE and no array-spec
2015-06-11 22:05 ` Thomas Koenig
2015-06-12 8:00 ` Andre Vehreschild
@ 2015-06-15 10:43 ` Andre Vehreschild
1 sibling, 0 replies; 21+ messages in thread
From: Andre Vehreschild @ 2015-06-15 10:43 UTC (permalink / raw)
To: Thomas Koenig; +Cc: GCC-Patches-ML, GCC-Fortran-ML
[-- Attachment #1: Type: text/plain, Size: 1294 bytes --]
Hi Thomas, hi all,
I got no objections so far, therefore commited as r224477. Thanks for the
review.
Regards,
Andre
On Thu, 11 Jun 2015 23:59:48 +0200
Thomas Koenig <tkoenig@netcologne.de> wrote:
> Hi Andre,
>
> > please find attached an updated version of the patch. This patch simplifies
> > some cases and ensures more straight line code. Furthermore was a bug in the
> > interfacing routine for the _vptr->_copy() routine removed, where not the
> > third and fourth arguments translated to be passed be value but the fourth
> > and fifth (cs start counting at zero...).
> >
> > Bootstraps and regtests fine on x86_64-linux-gnu/f21.
> >
> > Ok for trunk?
>
> Following the discussions, and looking through the patch, I would say
> this patch is in pretty good shape (and quite impressive, too).
>
> My vote would be to commit as is, unless something important comes up,
> and fix smaller problems and possible corner cases afterwards, if any
> exist. However, I am not really deep into these aspects of the
> compiler, and I would still like to leave some time for others to
> comment if they think this is appropriate.
>
> So, OK to commit in two days unless there are objections.
>
> Thanks for the patch!
>
> Thomas
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
[-- Attachment #2: submit.diff --]
[-- Type: text/x-patch, Size: 31037 bytes --]
Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog (Revision 224476)
+++ gcc/fortran/ChangeLog (Arbeitskopie)
@@ -1,3 +1,35 @@
+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>
* intrinsic.texi: Change \leq to < in descrition of imaginary
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (Revision 224476)
+++ gcc/fortran/gfortran.h (Arbeitskopie)
@@ -2395,6 +2395,9 @@
{
gfc_typespec ts;
gfc_alloc *list;
+ /* Take the array specification from expr3 to allocate arrays
+ without an explicit array specification. */
+ unsigned arr_spec_from_expr3:1;
}
alloc;
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (Revision 224476)
+++ gcc/fortran/resolve.c (Arbeitskopie)
@@ -6805,7 +6805,7 @@
have a trailing array reference that gives the size of the array. */
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 codimension;
@@ -7104,13 +7104,24 @@
if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL
|| (dimension && ref2->u.ar.dimen == 0))
{
- gfc_error ("Array specification required in ALLOCATE statement "
- "at %L", &e->where);
- goto failure;
+ /* F08:C633. */
+ if (code->expr3)
+ {
+ 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
- context of an ALLOCATE specification. */
+ context of an ALLOCATE specification. */
ar = &ref2->u.ar;
@@ -7125,7 +7136,7 @@
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;
switch (ar->dimen_type[i])
@@ -7202,6 +7213,7 @@
return false;
}
+
static void
resolve_allocate_deallocate (gfc_code *code, const char *fcn)
{
@@ -7376,8 +7388,16 @@
if (strcmp (fcn, "ALLOCATE") == 0)
{
+ bool arr_alloc_wo_spec = false;
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
{
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (Revision 224476)
+++ gcc/fortran/trans-array.c (Arbeitskopie)
@@ -4998,7 +4998,8 @@
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock,
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 tmp;
@@ -5041,7 +5042,18 @@
/* Set lower bound. */
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;
else
{
@@ -5069,10 +5081,35 @@
/* Set upper bound. */
gfc_init_se (&se, NULL);
- gcc_assert (ubound);
- gfc_conv_expr_type (&se, ubound, gfc_array_index_type);
- gfc_add_block_to_block (pblock, &se.pre);
-
+ 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. 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_rank_cst[n], se.expr);
conv_ubound = se.expr;
@@ -5242,6 +5279,33 @@
}
+/* 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
the work for an ALLOCATE statement. */
/*GCC ARRAYS*/
@@ -5249,7 +5313,8 @@
bool
gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
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 pointer;
@@ -5267,22 +5332,25 @@
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
- bool allocatable, coarray, dimension;
+ bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false;
ref = expr->ref;
/* 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
- || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0));
- prev_ref = ref;
- ref = ref->next;
+ /* F08:C633: Array shape from expr3. */
+ ref = expr3->ref;
+
+ /* Find the last reference in the chain. */
+ if (!retrieve_last_ref (&ref, &prev_ref))
+ return false;
+ alloc_w_e3_arr_spec = true;
}
- if (ref == NULL || ref->type != REF_ARRAY)
- return false;
-
if (!prev_ref)
{
allocatable = expr->symtree->n.sym->attr.allocatable;
@@ -5317,7 +5385,8 @@
break;
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;
upper = ref->u.ar.as->upper;
@@ -5331,10 +5400,12 @@
overflow = integer_zero_node;
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,
&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)
{
@@ -7073,6 +7144,16 @@
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)
{
/* Get a pointer to the new descriptor. */
Index: gcc/fortran/trans-array.h
===================================================================
--- gcc/fortran/trans-array.h (Revision 224476)
+++ gcc/fortran/trans-array.h (Arbeitskopie)
@@ -24,7 +24,7 @@
/* Generate code to initialize and allocate an array. Statements are added to
se, which should contain an expression for the array descriptor. */
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. */
void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *,
Index: gcc/fortran/trans-expr.c
===================================================================
--- gcc/fortran/trans-expr.c (Revision 224476)
+++ gcc/fortran/trans-expr.c (Arbeitskopie)
@@ -4561,6 +4561,7 @@
int has_alternate_specifier = 0;
bool need_interface_mapping;
bool callee_alloc;
+ bool ulim_copy;
gfc_typespec ts;
gfc_charlen cl;
gfc_expr *e;
@@ -4569,6 +4570,7 @@
enum {MISSING = 0, ELEMENTAL, SCALAR, SCALAR_POINTER, ARRAY};
gfc_component *comp = NULL;
int arglen;
+ unsigned int argc;
arglist = NULL;
retargs = NULL;
@@ -4624,10 +4626,16 @@
}
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. */
- for (arg = args; arg != NULL;
- arg = arg->next, formal = formal ? formal->next : NULL)
+ for (arg = args, argc = 0; arg != NULL;
+ arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
{
e = arg->expr;
fsym = formal ? formal->sym : NULL;
@@ -4729,7 +4737,14 @@
gfc_init_se (&parmse, se);
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);
else
gfc_conv_expr_reference (&parmse, e);
@@ -5322,7 +5337,7 @@
if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS)
&& e->ts.u.derived->attr.alloc_comp
&& !(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;
tmp = build_fold_indirect_ref_loc (input_location,
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (Revision 224476)
+++ gcc/fortran/trans-stmt.c (Arbeitskopie)
@@ -5098,6 +5098,8 @@
the trees may be the NULL_TREE indicating that this is not
available for expr3's type. */
tree expr3, expr3_vptr, expr3_len, expr3_esize;
+ /* Classify what expr3 stores. */
+ enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is;
stmtblock_t block;
stmtblock_t post;
tree nelems;
@@ -5110,6 +5112,7 @@
stat = tmp = memsz = al_vptr = al_len = NULL_TREE;
expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE;
label_errmsg = label_finish = errmsg = errlen = NULL_TREE;
+ e3_is = E3_UNSET;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -5149,10 +5152,7 @@
expression. */
if (code->expr3)
{
- bool vtab_needed = false;
- /* expr3_tmp gets the tree when code->expr3.mold is set, i.e.,
- the expression is only needed to get the _vptr, _len a.s.o. */
- tree expr3_tmp = NULL_TREE;
+ bool vtab_needed = false, temp_var_needed = false;
/* Figure whether we need the vtab from expr3. */
for (al = code->ext.alloc.list; !vtab_needed && al != NULL;
@@ -5159,6 +5159,7 @@
al = al->next)
vtab_needed = (al->expr->ts.type == BT_CLASS);
+ gfc_init_se (&se, NULL);
/* When expr3 is a variable, i.e., a very simple expression,
then convert it once here. */
if (code->expr3->expr_type == EXPR_VARIABLE
@@ -5167,31 +5168,25 @@
{
if (!code->expr3->mold
|| code->expr3->ts.type == BT_CHARACTER
- || vtab_needed)
+ || vtab_needed
+ || code->ext.alloc.arr_spec_from_expr3)
{
- /* Convert expr3 to a tree. */
- gfc_init_se (&se, NULL);
- /* For all "simple" expression just get the descriptor or the
- reference, respectively, depending on the rank of the expr. */
- if (code->expr3->rank != 0)
+ /* Convert expr3 to a tree. For all "simple" expression just
+ get the descriptor or the reference, respectively, depending
+ on the rank of the expr. */
+ if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0)
gfc_conv_expr_descriptor (&se, code->expr3);
else
gfc_conv_expr_reference (&se, code->expr3);
- if (!code->expr3->mold)
- expr3 = se.expr;
- else
- expr3_tmp = se.expr;
- expr3_len = se.string_length;
- gfc_add_block_to_block (&block, &se.pre);
- gfc_add_block_to_block (&post, &se.post);
+ /* Create a temp variable only for component refs to prevent
+ having to go through the full deref-chain each time and to
+ simplfy computation of array properties. */
+ temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF;
}
- /* else expr3 = NULL_TREE set above. */
}
else
{
- /* In all other cases evaluate the expr3 and create a
- temporary. */
- gfc_init_se (&se, NULL);
+ /* In all other cases evaluate the expr3. */
symbol_attribute attr;
/* Get the descriptor for all arrays, that are not allocatable or
pointer, because the latter are descriptors already. */
@@ -5205,45 +5200,55 @@
code->expr3->ts,
false, true,
false, false);
- gfc_add_block_to_block (&block, &se.pre);
- gfc_add_block_to_block (&post, &se.post);
+ temp_var_needed = !VAR_P (se.expr);
+ }
+ gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_block_to_block (&post, &se.post);
+ /* Prevent aliasing, i.e., se.expr may be already a
+ variable declaration. */
+ if (se.expr != NULL_TREE && temp_var_needed)
+ {
+ tree var;
+ tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) ?
+ se.expr
+ : build_fold_indirect_ref_loc (input_location, se.expr);
+ /* We need a regular (non-UID) symbol here, therefore give a
+ prefix. */
+ var = gfc_create_var (TREE_TYPE (tmp), "source");
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
+ {
+ gfc_allocate_lang_decl (var);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
+ }
+ gfc_add_modify_loc (input_location, &block, var, tmp);
- /* Prevent aliasing, i.e., se.expr may be already a
- variable declaration. */
- if (!VAR_P (se.expr))
+ /* Deallocate any allocatable components after all the allocations
+ and assignments of expr3 have been completed. */
+ if (code->expr3->ts.type == BT_DERIVED
+ && code->expr3->rank == 0
+ && code->expr3->ts.u.derived->attr.alloc_comp)
{
- tree var;
- tmp = build_fold_indirect_ref_loc (input_location,
- se.expr);
- /* We need a regular (non-UID) symbol here, therefore give a
- prefix. */
- var = gfc_create_var (TREE_TYPE (tmp), "source");
- gfc_add_modify_loc (input_location, &block, var, tmp);
+ tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
+ var, 0);
+ gfc_add_expr_to_block (&post, tmp);
+ }
- /* Deallocate any allocatable components after all the allocations
- and assignments of expr3 have been completed. */
- if (code->expr3->ts.type == BT_DERIVED
- && code->expr3->rank == 0
- && code->expr3->ts.u.derived->attr.alloc_comp)
- {
- tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived,
- var, 0);
- gfc_add_expr_to_block (&post, tmp);
- }
-
- tmp = var;
- }
- else
- tmp = se.expr;
- if (!code->expr3->mold)
- expr3 = tmp;
- else
- expr3_tmp = tmp;
- /* When he length of a char array is easily available
- here, fix it for future use. */
+ expr3 = var;
if (se.string_length)
+ /* Evaluate it assuming that it also is complicated like expr3. */
expr3_len = gfc_evaluate_now (se.string_length, &block);
}
+ else
+ {
+ expr3 = se.expr;
+ expr3_len = se.string_length;
+ }
+ /* Store what the expr3 is to be used for. */
+ e3_is = expr3 != NULL_TREE ?
+ (code->ext.alloc.arr_spec_from_expr3 ?
+ E3_DESC
+ : (code->expr3->mold ? E3_MOLD : E3_SOURCE))
+ : E3_UNSET;
/* Figure how to get the _vtab entry. This also obtains the tree
expression for accessing the _len component, because only
@@ -5258,10 +5263,6 @@
if (expr3 != NULL_TREE && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))
&& (VAR_P (expr3) || !code->expr3->ref))
tmp = gfc_class_vptr_get (expr3);
- else if (expr3_tmp != NULL_TREE
- && GFC_CLASS_TYPE_P (TREE_TYPE (expr3_tmp))
- && (VAR_P (expr3_tmp) || !code->expr3->ref))
- tmp = gfc_class_vptr_get (expr3_tmp);
else
{
rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
@@ -5281,9 +5282,7 @@
{
/* Same like for retrieving the _vptr. */
if (expr3 != NULL_TREE && !code->expr3->ref)
- expr3_len = gfc_class_len_get (expr3);
- else if (expr3_tmp != NULL_TREE && !code->expr3->ref)
- expr3_len = gfc_class_len_get (expr3_tmp);
+ expr3_len = gfc_class_len_get (expr3);
else
{
rhs = gfc_find_and_cut_at_last_class_ref (code->expr3);
@@ -5344,8 +5343,11 @@
advantage is, that we get scalarizer support for free,
don't have to take care about scalar to array treatment and
will benefit of every enhancements gfc_trans_assignment ()
- gets. */
- if (expr3 != NULL_TREE && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
+ gets.
+ No need to check whether e3_is is E3_UNSET, because that is
+ done by expr3 != NULL_TREE. */
+ if (e3_is != E3_MOLD && expr3 != NULL_TREE
+ && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
{
/* Build a temporary symtree and symbol. Do not add it to
the current namespace to prevent accidently modifying
@@ -5397,6 +5399,12 @@
}
gcc_assert (expr3_esize);
expr3_esize = fold_convert (sizetype, expr3_esize);
+ if (e3_is == E3_MOLD)
+ {
+ /* The expr3 is no longer valid after this point. */
+ expr3 = NULL_TREE;
+ e3_is = E3_UNSET;
+ }
}
else if (code->ext.alloc.ts.type != BT_UNKNOWN)
{
@@ -5496,7 +5504,11 @@
else
tmp = expr3_esize;
if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen,
- label_finish, tmp, &nelems, code->expr3))
+ label_finish, tmp, &nelems,
+ e3rhs ? e3rhs : code->expr3,
+ e3_is == E3_DESC ? expr3 : NULL_TREE,
+ code->expr3 != NULL && e3_is == E3_DESC
+ && code->expr3->expr_type == EXPR_ARRAY))
{
/* A scalar or derived type. First compute the size to
allocate.
@@ -5702,11 +5714,15 @@
if (expr3 != NULL_TREE
&& ((POINTER_TYPE_P (TREE_TYPE (expr3))
&& TREE_CODE (expr3) != POINTER_PLUS_EXPR)
- || (VAR_P (expr3) && GFC_CLASS_TYPE_P (TREE_TYPE (expr3))))
+ || (VAR_P (expr3) && GFC_CLASS_TYPE_P (
+ TREE_TYPE (expr3))))
&& code->expr3->ts.type == BT_CLASS
&& (expr->ts.type == BT_CLASS
|| expr->ts.type == BT_DERIVED))
{
+ /* copy_class_to_class can be used for class arrays, too.
+ It just needs to be ensured, that the decl_saved_descriptor
+ has a way to get to the vptr. */
tree to;
to = VAR_P (se.expr) ? se.expr : TREE_OPERAND (se.expr, 0);
tmp = gfc_copy_class_to_class (expr3, to,
@@ -5740,30 +5756,14 @@
if (dataref && dataref->u.c.component->as)
{
- int dim;
- gfc_expr *temp;
- gfc_ref *ref = dataref->next;
- ref->u.ar.type = AR_SECTION;
- /* We have to set up the array reference to give ranges
- in all dimensions and ensure that the end and stride
- are set so that the copy can be scalarized. */
- dim = 0;
- for (; dim < dataref->u.c.component->as->rank; dim++)
- {
- ref->u.ar.dimen_type[dim] = DIMEN_RANGE;
- if (ref->u.ar.end[dim] == NULL)
- {
- ref->u.ar.end[dim] = ref->u.ar.start[dim];
- temp = gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1);
- ref->u.ar.start[dim] = temp;
- }
- temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]),
- gfc_copy_expr (ref->u.ar.start[dim]));
- temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind,
- &al->expr->where, 1),
- temp);
- }
+ gfc_array_spec *as = dataref->u.c.component->as;
+ gfc_free_ref_list (dataref->next);
+ dataref->next = NULL;
+ gfc_add_full_array_ref (last_arg->expr, as);
+ gfc_resolve_expr (last_arg->expr);
+ gcc_assert (last_arg->expr->ts.type == BT_CLASS
+ || last_arg->expr->ts.type == BT_DERIVED);
+ last_arg->expr->ts.type = BT_CLASS;
}
if (rhs->ts.type == BT_CLASS)
{
@@ -5845,7 +5845,7 @@
gfc_add_expr_to_block (&block, tmp);
}
else if (code->expr3 && code->expr3->mold
- && code->expr3->ts.type == BT_CLASS)
+ && code->expr3->ts.type == BT_CLASS)
{
/* Since the _vptr has already been assigned to the allocate
object, we can use gfc_copy_class_to_class in its
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog (Revision 224476)
+++ gcc/testsuite/ChangeLog (Arbeitskopie)
@@ -1,3 +1,13 @@
+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>
PR c++/65168
Index: gcc/testsuite/gfortran.dg/allocate_with_source_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 (Revision 224476)
+++ gcc/testsuite/gfortran.dg/allocate_with_source_3.f90 (Arbeitskopie)
@@ -21,7 +21,7 @@
type(cstruct), pointer :: u(:)
! 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)
deallocate (u)
Index: gcc/testsuite/gfortran.dg/allocate_with_source_7.f08
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 (Revision 0)
+++ gcc/testsuite/gfortran.dg/allocate_with_source_7.f08 (Arbeitskopie)
@@ -0,0 +1,79 @@
+! { 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
+
Index: gcc/testsuite/gfortran.dg/allocate_with_source_8.f08
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 (Revision 0)
+++ gcc/testsuite/gfortran.dg/allocate_with_source_8.f08 (Arbeitskopie)
@@ -0,0 +1,110 @@
+! { 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
^ permalink raw reply [flat|nested] 21+ messages in thread
end of thread, other threads:[~2015-06-15 10:26 UTC | newest]
Thread overview: 21+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2015-03-30 17:48 [Patch, fortran, PR44672, v1] [F08] ALLOCATE with SOURCE and no array-spec Andre Vehreschild
2015-04-01 13:15 ` [Patch, fortran, PR44672, v2] " Andre Vehreschild
2015-04-02 9:03 ` [Patch, fortran, PR44672, v3] " Andre Vehreschild
2015-04-23 12:45 ` [Ping, Patch, " Andre Vehreschild
2015-04-29 15:29 ` [Patch, fortran, PR44672, v4] " Andre Vehreschild
2015-04-30 14:31 ` [Patch, fortran, PR44672, v5] " Andre Vehreschild
2015-05-19 10:29 ` [Patch, fortran, PR44672, v6] " Andre Vehreschild
2015-05-22 10:24 ` Ping: " Andre Vehreschild
2015-05-25 19:35 ` Mikael Morin
2015-05-28 15:48 ` Andre Vehreschild
2015-05-28 18:42 ` Mikael Morin
2015-05-29 12:41 ` Andre Vehreschild
2015-05-30 4:23 ` Thomas Koenig
2015-06-02 16:52 ` Mikael Morin
2015-06-03 15:25 ` Andre Vehreschild
2015-06-05 12:04 ` [Patch, fortran, PR44672, v9] " Andre Vehreschild
2015-06-09 5:36 ` Damian Rouson
2015-06-10 8:59 ` [Patch, fortran, PR44672, v10] " Andre Vehreschild
2015-06-11 22:05 ` Thomas Koenig
2015-06-12 8:00 ` Andre Vehreschild
2015-06-15 10:43 ` Andre Vehreschild
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).