Skip to content

R
riscv-gcc-1
Commit f33beee9 by Tobias Burnus Committed by Tobias Burnus
Options

re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays]) 

2010-04-27  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * resolve.c (resolve_allocate_expr): Allow array coarrays.
        * trans-types.h (gfc_get_array_type_bounds): Update prototype.
        * trans-types.c (gfc_get_array_type_bounds,
        gfc_get_array_descriptor_base): Add corank argument.
        * trans-array.c (gfc_array_init_size): Handle corank.
        (gfc_trans_create_temp_array, gfc_array_allocate,
        gfc_conv_expr_descriptor): Add corank argument to call.
        * trans-stmt.c (gfc_trans_pointer_assign_need_temp): Ditto.

2010-04-27  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.dg/coarray_7.f90: Modified and removed obsolete
        tests.
        * gfortran.dg/coarray_12.f90: New.

From-SVN: r158768
parent d89488ec
Showing with 185 additions and 63 deletions
gcc/fortran/ChangeLog
2010-04-27 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* resolve.c (resolve_allocate_expr): Allow array coarrays.
* trans-types.h (gfc_get_array_type_bounds): Update prototype.
* trans-types.c (gfc_get_array_type_bounds,
gfc_get_array_descriptor_base): Add corank argument.
* trans-array.c (gfc_array_init_size): Handle corank.
(gfc_trans_create_temp_array, gfc_array_allocate,
gfc_conv_expr_descriptor): Add corank argument to call.
* trans-stmt.c (gfc_trans_pointer_assign_need_temp): Ditto.
2010-04-24 Steven G. Kargl <kargl@gcc.gnu.org>
PR fortran/30073
......
gcc/fortran/resolve.c
......@@ -6561,9 +6561,9 @@ check_symbols:
goto failure;
}
if (codimension)
if (codimension && ar->as->rank == 0)
{
gfc_error ("Sorry, allocatable coarrays are no yet supported coarray "
gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
"at %L", &e->where);
goto failure;
}
......
gcc/fortran/trans-array.c
......@@ -725,7 +725,7 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post,
/* Initialize the descriptor. */
type =
gfc_get_array_type_bounds (eltype, info->dimen, loop->from, loop->to, 1,
gfc_get_array_type_bounds (eltype, info->dimen, 0, loop->from, loop->to, 1,
GFC_ARRAY_UNKNOWN, true);
desc = gfc_create_var (type, "atmp");
GFC_DECL_PACKED_ARRAY (desc) = 1;
......@@ -3819,7 +3819,7 @@ gfc_conv_loop_setup (gfc_loopinfo * loop, locus * where)
/*GCC ARRAYS*/
static tree
gfc_array_init_size (tree descriptor, int rank, tree * poffset,
gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper,
stmtblock_t * pblock)
{
......@@ -3917,6 +3917,43 @@ gfc_array_init_size (tree descriptor, int rank, tree * poffset,
stride = gfc_evaluate_now (stride, pblock);
}
for (n = rank; n < rank + corank; n++)
{
ubound = upper[n];
/* Set lower bound. */
gfc_init_se (&se, NULL);
if (lower == NULL || lower[n] == NULL)
{
gcc_assert (n == rank + corank - 1);
se.expr = gfc_index_one_node;
}
else
{
if (ubound || n == rank + corank - 1)
{
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 (pblock, descriptor, gfc_rank_cst[n],
se.expr);
if (n < rank + corank - 1)
{
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 (pblock, descriptor, gfc_rank_cst[n], se.expr);
}
}
/* The stride is the number of elements in the array, so multiply by the
size of an element to get the total size. */
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
......@@ -3965,7 +4002,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
bool allocatable_array;
bool allocatable_array, coarray;
ref = expr->ref;
......@@ -3981,29 +4018,40 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
if (ref == NULL || ref->type != REF_ARRAY)
return false;
/* Return if this is a scalar coarray. */
if (!prev_ref && !expr->symtree->n.sym->attr.dimension)
if (!prev_ref)
{
gcc_assert (expr->symtree->n.sym->attr.codimension);
return false;
allocatable_array = expr->symtree->n.sym->attr.allocatable;
coarray = expr->symtree->n.sym->attr.codimension;
}
else if (prev_ref && !prev_ref->u.c.component->attr.dimension)
else
{
gcc_assert (prev_ref->u.c.component->attr.codimension);
return false;
allocatable_array = prev_ref->u.c.component->attr.allocatable;
coarray = prev_ref->u.c.component->attr.codimension;
}
if (!prev_ref)
allocatable_array = expr->symtree->n.sym->attr.allocatable;
else
allocatable_array = prev_ref->u.c.component->attr.allocatable;
/* Return if this is a scalar coarray. */
if ((!prev_ref && !expr->symtree->n.sym->attr.dimension)
|| (prev_ref && !prev_ref->u.c.component->attr.dimension))
{
gcc_assert (coarray);
return false;
}
/* Figure out the size of the array. */
switch (ref->u.ar.type)
{
case AR_ELEMENT:
lower = NULL;
upper = ref->u.ar.start;
if (!coarray)
{
lower = NULL;
upper = ref->u.ar.start;
break;
}
/* Fall through. */
case AR_SECTION:
lower = ref->u.ar.start;
upper = ref->u.ar.end;
break;
case AR_FULL:
......@@ -4013,18 +4061,14 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
upper = ref->u.ar.as->upper;
break;
case AR_SECTION:
lower = ref->u.ar.start;
upper = ref->u.ar.end;
break;
default:
gcc_unreachable ();
break;
}
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
lower, upper, &se->pre);
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
&se->pre);
/* Allocate memory to store the data. */
pointer = gfc_conv_descriptor_data_get (se->expr);
......@@ -5299,7 +5343,7 @@ gfc_conv_expr_descriptor (gfc_se * se, gfc_expr * expr, gfc_ss * ss)
{
/* Otherwise make a new one. */
parmtype = gfc_get_element_type (TREE_TYPE (desc));
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
loop.from, loop.to, 0,
GFC_ARRAY_UNKNOWN, false);
parm = gfc_create_var (parmtype, "parm");
......
gcc/fortran/trans-stmt.c
......@@ -2822,7 +2822,7 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
/* Make a new descriptor. */
parmtype = gfc_get_element_type (TREE_TYPE (desc));
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0,
loop.from, loop.to, 1,
GFC_ARRAY_UNKNOWN, true);
......
gcc/fortran/trans-types.c
......@@ -1222,8 +1222,8 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
if (as->type == AS_ASSUMED_SHAPE)
akind = GFC_ARRAY_ASSUMED_SHAPE;
return gfc_get_array_type_bounds (type, as->rank, lbound, ubound, 0, akind,
restricted);
return gfc_get_array_type_bounds (type, as->rank, as->corank, lbound,
ubound, 0, akind, restricted);
}
/* Returns the struct descriptor_dimension type. */
......@@ -1538,20 +1538,21 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
/* Return or create the base type for an array descriptor. */
static tree
gfc_get_array_descriptor_base (int dimen, bool restricted)
gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
{
tree fat_type, fieldlist, decl, arraytype;
char name[16 + GFC_RANK_DIGITS + 1];
char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
int idx = 2 * (dimen - 1) + restricted;
gcc_assert (dimen >= 1 && dimen <= GFC_MAX_DIMENSIONS);
gcc_assert (dimen >= 1 && codimen + dimen <= GFC_MAX_DIMENSIONS);
if (gfc_array_descriptor_base[idx])
return gfc_array_descriptor_base[idx];
/* Build the type node. */
fat_type = make_node (RECORD_TYPE);
sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT, dimen);
sprintf (name, "array_descriptor" GFC_RANK_PRINTF_FORMAT "_"
GFC_RANK_PRINTF_FORMAT, dimen, codimen);
TYPE_NAME (fat_type) = get_identifier (name);
/* Add the data member as the first element of the descriptor. */
......@@ -1583,7 +1584,7 @@ gfc_get_array_descriptor_base (int dimen, bool restricted)
build_array_type (gfc_get_desc_dim_type (),
build_range_type (gfc_array_index_type,
gfc_index_zero_node,
gfc_rank_cst[dimen - 1]));
gfc_rank_cst[codimen + dimen - 1]));
decl = build_decl (input_location,
FIELD_DECL, get_identifier ("dim"), arraytype);
......@@ -1604,20 +1605,20 @@ gfc_get_array_descriptor_base (int dimen, bool restricted)
/* Build an array (descriptor) type with given bounds. */
tree
gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
tree * ubound, int packed,
enum gfc_array_kind akind, bool restricted)
{
char name[8 + GFC_RANK_DIGITS + GFC_MAX_SYMBOL_LEN];
char name[8 + 2*GFC_RANK_DIGITS + 1 + GFC_MAX_SYMBOL_LEN];
tree fat_type, base_type, arraytype, lower, upper, stride, tmp, rtype;
const char *type_name;
int n;
base_type = gfc_get_array_descriptor_base (dimen, restricted);
base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
fat_type = build_distinct_type_copy (base_type);
/* Make sure that nontarget and target array type have the same canonical
type (and same stub decl for debug info). */
base_type = gfc_get_array_descriptor_base (dimen, false);
base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
TYPE_CANONICAL (fat_type) = base_type;
TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
......@@ -1628,7 +1629,8 @@ gfc_get_array_type_bounds (tree etype, int dimen, tree * lbound,
type_name = IDENTIFIER_POINTER (tmp);
else
type_name = "unknown";
sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_%.*s", dimen,
sprintf (name, "array" GFC_RANK_PRINTF_FORMAT "_"
GFC_RANK_PRINTF_FORMAT "_%.*s", dimen, codimen,
GFC_MAX_SYMBOL_LEN, type_name);
TYPE_NAME (fat_type) = get_identifier (name);
......
gcc/fortran/trans-types.h
......@@ -72,7 +72,7 @@ tree gfc_type_for_mode (enum machine_mode, int);
tree gfc_build_uint_type (int);
tree gfc_get_element_type (tree);
tree gfc_get_array_type_bounds (tree, int, tree *, tree *, int,
tree gfc_get_array_type_bounds (tree, int, int, tree *, tree *, int,
enum gfc_array_kind, bool);
tree gfc_get_nodesc_array_type (tree, gfc_array_spec *, gfc_packed, bool);
......
gcc/testsuite/ChangeLog
2010-04-27 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
* gfortran.dg/coarray_7.f90: Modified and removed obsolete tests.
* gfortran.dg/coarray_12.f90: New.
2010-04-27 Shujing Zhao <pearly.zhao@oracle.com>
PR c/32207
......
gcc/testsuite/gfortran.dg/coarray_12.f90 0 → 100644
! { dg-do compile }
! { dg-options "-fcoarray=single -fdump-tree-original" }
!
! Coarray support -- allocatable array coarrays
! PR fortran/18918
!
integer,allocatable :: a(:)[:,:]
nn = 5
mm = 7
allocate(a(nn)[mm,*])
end
subroutine testAlloc3
implicit none
integer, allocatable :: ab(:,:,:)[:,:]
integer, allocatable, dimension(:),codimension[:] :: b(:,:,:)[:,:]
integer, allocatable, dimension(:,:),codimension[:,:,:] :: c
integer, allocatable, dimension(:,:),codimension[:,:,:] :: d[:,:]
integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: e(:,:)
integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: f(:,:)[:,:]
allocate(ab(1,2,3)[4,*])
allocate(b(1,2,3)[4,*])
allocate(c(1,2)[3,4,*])
allocate(d(1,2)[3,*])
allocate(e(1,2)[3,4,*])
allocate(f(1,2)[3,*])
end subroutine testAlloc3
subroutine testAlloc4()
implicit none
integer, allocatable :: xxx(:)[:,:,:,:]
integer :: mmm
mmm=88
allocate(xxx(1)[7,-5:8,mmm:2,*])
end subroutine testAlloc4
subroutine testAlloc5()
implicit none
integer, allocatable :: yyy(:)[:,:,:,:]
integer :: ooo, ppp
ooo=88
ppp=42
allocate(yyy(1)[7,-5:ppp,1,ooo:*])
end subroutine testAlloc5
! { dg-final { scan-tree-dump-times "a.dim.0..lbound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "a.dim.0..ubound = .* nn;" 1 "original" } }
! { dg-final { scan-tree-dump-times "a.dim.1..lbound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "a.dim.1..ubound = .* mm;" 1 "original" } }
! { dg-final { scan-tree-dump-times "a.dim.2..lbound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "a.dim.2..ubound" 0 "original" } }
! { dg-final { scan-tree-dump-times "xxx.dim.0..lbound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "xxx.dim.0..ubound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "xxx.dim.1..lbound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "xxx.dim.1..ubound = 7;" 1 "original" } }
! { dg-final { scan-tree-dump-times "xxx.dim.2..lbound = -5;" 1 "original" } }
! { dg-final { scan-tree-dump-times "xxx.dim.2..ubound = 8;" 1 "original" } }
! { dg-final { scan-tree-dump-times "xxx.dim.3..lbound = .*mmm;" 1 "original" } }
! { dg-final { scan-tree-dump-times "xxx.dim.3..ubound = 2;" 1 "original" } }
! { dg-final { scan-tree-dump-times "xxx.dim.4..lbound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "xxx.dim.4..ubound" 0 "original" } }
! { dg-final { scan-tree-dump-times "yyy.dim.0..lbound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "yyy.dim.0..ubound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "yyy.dim.1..lbound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "yyy.dim.1..ubound = 7;" 1 "original" } }
! { dg-final { scan-tree-dump-times "yyy.dim.2..lbound = -5;" 1 "original" } }
! { dg-final { scan-tree-dump-times "yyy.dim.2..ubound = .*ppp;" 1 "original" } }
! { dg-final { scan-tree-dump-times "yyy.dim.3..lbound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "yyy.dim.3..ubound = 1;" 1 "original" } }
! { dg-final { scan-tree-dump-times "yyy.dim.4..lbound = .*ooo;" 1 "original" } }
! { dg-final { scan-tree-dump-times "yyy.dim.4..ubound" 0 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
gcc/testsuite/gfortran.dg/coarray_7.f90
......@@ -91,7 +91,6 @@ type(t), allocatable :: b(:)[:], C[:]
allocate(b(1)) ! { dg-error "Coarray specification" }
allocate(a[3]%a(5)) ! { dg-error "Coindexed allocatable" }
allocate(c[*]) ! { dg-error "Sorry" }
allocate(b(3)[5:*]) ! { dg-error "Sorry" }
allocate(a%a(5)) ! OK
end subroutine alloc
......@@ -148,34 +147,16 @@ end subroutine test4
subroutine allocateTest()
implicit none
real, allocatable,dimension(:,:), codimension[:,:] :: a,b,c
real, allocatable, codimension[:,:] :: a,b,c
integer :: n, q
n = 1
q = 1
allocate(a(n,n)[q,*]) ! { dg-error "Sorry" }
allocate(b(n,n)[q,*]) ! { dg-error "Sorry" }
allocate(c(n,n)[q,*]) ! { dg-error "Sorry" }
allocate(a[q,*]) ! { dg-error "Sorry" }
allocate(b[q,*]) ! { dg-error "Sorry" }
allocate(c[q,*]) ! { dg-error "Sorry" }
end subroutine allocateTest
subroutine testAlloc3
implicit none
integer, allocatable :: a(:,:,:)[:,:]
integer, allocatable, dimension(:),codimension[:] :: b(:,:,:)[:,:]
integer, allocatable, dimension(:,:),codimension[:,:,:] :: c
integer, allocatable, dimension(:,:),codimension[:,:,:] :: d[:,:]
integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: e(:,:)
integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: f(:,:)[:,:]
allocate(a(1,2,3)[4,*]) ! { dg-error "Sorry" }
allocate(b(1,2,3)[4,*]) ! { dg-error "Sorry" }
allocate(c(1,2)[3,4,*]) ! { dg-error "Sorry" }
allocate(d(1,2)[3,*]) ! { dg-error "Sorry" }
allocate(e(1,2)[3,4,*]) ! { dg-error "Sorry" }
allocate(f(1,2)[3,*]) ! { dg-error "Sorry" }
end subroutine testAlloc3
subroutine testAlloc4()
implicit none
type co_double_3
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment