procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

expr.c (gfc_ref_this_image): New function.

Browse source 
2011-07-16  Tobias Burnus  <burnus@net-b.de>

        * expr.c (gfc_ref_this_image): New function.
        (gfc_is_coindexed): Use it.
        * gfortran.h (gfc_ref_this_image): New prototype.
        * resolve.c (resolve_deallocate_expr,
        resolve_allocate_expr): Support alloc scalar coarrays.
        * trans-array.c (gfc_conv_array_ref, gfc_array_init_size,
        gfc_conv_descriptor_cosize, gfc_array_allocate,
        gfc_trans_deferred_array): Ditto.
        * trans-expr.c (gfc_conv_variable) Ditto.:
        * trans-stmt.c (gfc_trans_deallocate): Ditto.
        * trans-types.c (gfc_get_element_type, gfc_get_array_type_bounds
        gfc_get_array_descr_info): Ditto.
        * trans-decl.c (gfc_get_symbol_decl): Ditto.

2011-07-16  Tobias Burnus  <burnus@net-b.de>

        * gfortran.dg/coarray_14.f90: Remove dg-error "sorry not
        * implemented".
        * gfortran.dg/coarray_7.f90: Ditto.
        * gfortran.dg/coarray/scalar_alloc_1.f90: New.
        * gfortran.dg/coarray/scalar_alloc_2.f90: New.

From-SVN: r176358
This commit is contained in:
Tobias Burnus 2011-07-16 19:31:13 +02:00
parent 0fa7144765
commit badd9e6941
14 changed files with 257 additions and 58 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
gcc/fortran/ChangeLog
View file

@ -1,3 +1,19 @@
2011-07-16 Tobias Burnus <burnus@net-b.de>
* expr.c (gfc_ref_this_image): New function.
(gfc_is_coindexed): Use it.
* gfortran.h (gfc_ref_this_image): New prototype.
* resolve.c (resolve_deallocate_expr,
resolve_allocate_expr): Support alloc scalar coarrays.
* trans-array.c (gfc_conv_array_ref, gfc_array_init_size,
gfc_conv_descriptor_cosize, gfc_array_allocate,
gfc_trans_deferred_array): Ditto.
* trans-expr.c (gfc_conv_variable) Ditto.:
* trans-stmt.c (gfc_trans_deallocate): Ditto.
* trans-types.c (gfc_get_element_type, gfc_get_array_type_bounds
gfc_get_array_descr_info): Ditto.
* trans-decl.c (gfc_get_symbol_decl): Ditto.
2011-07-11 Jakub Jelinek <jakub@redhat.com>
PR fortran/49698
@ -26,7 +42,7 @@
* trans.c (gfc_allocate_with_status): Call _gfortran_caf_register
with NULL arguments for (new) stat=/errmsg= arguments.
2011-07-06 Daniel Carrera <dcarrera@gmail.com>
2011-07-06 Daniel Carrera <dcarrera@gmail.com>
* trans-array.c (gfc_array_allocate): Rename allocatable_array to
allocatable. Rename function gfc_allocate_array_with_status to

22
gcc/fortran/expr.c
View file

@ -4125,6 +4125,21 @@ gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest)
}
bool
gfc_ref_this_image (gfc_ref *ref)
{
int n;
gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0);
for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
return false;
return true;
}
bool
gfc_is_coindexed (gfc_expr *e)
{
@ -4132,12 +4147,7 @@ gfc_is_coindexed (gfc_expr *e)
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
{
int n;
for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
return true;
}
return !gfc_ref_this_image (ref);
return false;
}

1
gcc/fortran/gfortran.h
View file

@ -2733,6 +2733,7 @@ void gfc_expr_replace_comp (gfc_expr *, gfc_component *);
bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **);
bool gfc_ref_this_image (gfc_ref *ref);
bool gfc_is_coindexed (gfc_expr *);
int gfc_get_corank (gfc_expr *);
bool gfc_has_ultimate_allocatable (gfc_expr *);

11
gcc/fortran/resolve.c
View file

@ -6460,7 +6460,9 @@ resolve_deallocate_expr (gfc_expr *e)
switch (ref->type)
{
case REF_ARRAY:
if (ref->u.ar.type != AR_FULL)
if (ref->u.ar.type != AR_FULL
&& !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
&& ref->u.ar.codimen && gfc_ref_this_image (ref)))
allocatable = 0;
break;
@ -6983,13 +6985,6 @@ check_symbols:
goto failure;
}
if (codimension && ar->as->rank == 0)
{
gfc_error ("Sorry, allocatable scalar coarrays are not yet supported "
"at %L", &e->where);
goto failure;
}
success:
return SUCCESS;

79
gcc/fortran/trans-array.c
View file

@ -2623,12 +2623,20 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
if (ar->dimen == 0)
{
gcc_assert (ar->codimen);
if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
&& TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
/* Use the actual tree type and not the wrapped coarray. */
se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)), se->expr);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se->expr)))
se->expr = build_fold_indirect_ref (gfc_conv_array_data (se->expr));
else
{
if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
&& TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
/* Use the actual tree type and not the wrapped coarray. */
se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
se->expr);
}
return;
}
@ -4139,7 +4147,11 @@ gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
overflow += size == 0 ? 0: (MAX/size < stride ? 1: 0);
stride = stride * size;
}
for (n = rank; n < rank+corank; n++)
(Set lcobound/ucobound as above.)
element_size = sizeof (array element);
if (!rank)
return element_size
stride = (size_t) stride;
overflow += element_size == 0 ? 0: (MAX/element_size < stride ? 1: 0);
stride = stride * element_size;
@ -4309,6 +4321,10 @@ gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset,
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
/* Convert to size_t. */
element_size = fold_convert (size_type_node, tmp);
if (rank == 0)
return element_size;
stride = fold_convert (size_type_node, stride);
/* First check for overflow. Since an array of type character can
@ -4370,18 +4386,18 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
{
tree tmp;
tree pointer;
tree offset;
tree offset = NULL_TREE;
tree size;
tree msg;
tree error;
tree error = NULL_TREE;
tree overflow; /* Boolean storing whether size calculation overflows. */
tree var_overflow;
tree var_overflow = NULL_TREE;
tree cond;
stmtblock_t elseblock;
gfc_expr **lower;
gfc_expr **upper;
gfc_ref *ref, *prev_ref = NULL;
bool allocatable, coarray;
bool allocatable, coarray, dimension;
ref = expr->ref;
@ -4401,20 +4417,17 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
{
allocatable = expr->symtree->n.sym->attr.allocatable;
coarray = expr->symtree->n.sym->attr.codimension;
dimension = expr->symtree->n.sym->attr.dimension;
}
else
{
allocatable = prev_ref->u.c.component->attr.allocatable;
coarray = prev_ref->u.c.component->attr.codimension;
dimension = prev_ref->u.c.component->attr.dimension;
}
/* 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;
}
if (!dimension)
gcc_assert (coarray);
/* Figure out the size of the array. */
switch (ref->u.ar.type)
@ -4449,16 +4462,20 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank,
ref->u.ar.as->corank, &offset, lower, upper,
&se->pre, &overflow);
if (dimension)
{
var_overflow = gfc_create_var (integer_type_node, "overflow");
gfc_add_modify (&se->pre, var_overflow, overflow);
var_overflow = gfc_create_var (integer_type_node, "overflow");
gfc_add_modify (&se->pre, var_overflow, overflow);
/* Generate the block of code handling overflow. */
msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
/* Generate the block of code handling overflow. */
msg = gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const
("Integer overflow when calculating the amount of "
"memory to allocate"));
error = build_call_expr_loc (input_location,
gfor_fndecl_runtime_error, 1, msg);
error = build_call_expr_loc (input_location, gfor_fndecl_runtime_error,
1, msg);
}
if (pstat != NULL_TREE && !integer_zerop (pstat))
{
@ -4495,14 +4512,20 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
gfc_add_expr_to_block (&elseblock, tmp);
cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
var_overflow, integer_zero_node));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
error, gfc_finish_block (&elseblock));
if (dimension)
{
cond = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, var_overflow, integer_zero_node));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
error, gfc_finish_block (&elseblock));
}
else
tmp = gfc_finish_block (&elseblock);
gfc_add_expr_to_block (&se->pre, tmp);
gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
if (dimension)
gfc_conv_descriptor_offset_set (&se->pre, se->expr, offset);
if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS)
&& expr->ts.u.derived->attr.alloc_comp)
@ -7446,7 +7469,7 @@ gfc_trans_deferred_array (gfc_symbol * sym, gfc_wrapped_block * block)
gfc_add_expr_to_block (&cleanup, tmp);
}
if (sym->attr.allocatable && sym->attr.dimension
if (sym->attr.allocatable && (sym->attr.dimension || sym->attr.codimension)
&& !sym->attr.save && !sym->attr.result)
{
tmp = gfc_trans_dealloc_allocated (sym->backend_decl);

7
gcc/fortran/trans-decl.c
View file

@ -1425,7 +1425,8 @@ gfc_get_symbol_decl (gfc_symbol * sym)
&& (sym->attr.save || sym->ns->proc_name->attr.is_main_program
|| gfc_option.flag_max_stack_var_size == 0
|| sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
&& (gfc_option.coarray != GFC_FCOARRAY_LIB || !sym->attr.codimension))
&& (gfc_option.coarray != GFC_FCOARRAY_LIB
|| !sym->attr.codimension || sym->attr.allocatable))
{
/* Add static initializer. For procedures, it is only needed if
SAVE is specified otherwise they need to be reinitialized
@ -1433,7 +1434,9 @@ gfc_get_symbol_decl (gfc_symbol * sym)
in this case due to -fmax-stack-var-size=. */
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
TREE_TYPE (decl),
sym->attr.dimension,
sym->attr.dimension
|| (sym->attr.codimension
&& sym->attr.allocatable),
sym->attr.pointer
|| sym->attr.allocatable,
sym->attr.proc_pointer);

8
gcc/fortran/trans-expr.c
View file

@ -691,8 +691,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
}
else if (!sym->attr.value)
{
/* Dereference non-character scalar dummy arguments. */
if (sym->attr.dummy && !sym->attr.dimension)
/* Dereference non-character scalar dummy arguments. */
if (sym->attr.dummy && !sym->attr.dimension
&& !(sym->attr.codimension && sym->attr.allocatable))
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
@ -711,7 +712,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result
|| !sym->attr.dimension))
|| (!sym->attr.dimension
&& (!sym->attr.codimension || !sym->attr.allocatable))))
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
}

2
gcc/fortran/trans-stmt.c
View file

@ -5104,7 +5104,7 @@ gfc_trans_deallocate (gfc_code *code)
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
if (expr->rank)
if (expr->rank || gfc_expr_attr (expr).codimension)
{
if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp)
{

22
gcc/fortran/trans-types.c
View file

@ -1125,8 +1125,9 @@ gfc_get_element_type (tree type)
gcc_assert (TREE_CODE (element) == POINTER_TYPE);
element = TREE_TYPE (element);
gcc_assert (TREE_CODE (element) == ARRAY_TYPE);
element = TREE_TYPE (element);
/* For arrays, which are not scalar coarrays. */
if (TREE_CODE (element) == ARRAY_TYPE)
element = TREE_TYPE (element);
}
return element;
@ -1770,6 +1771,16 @@ gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
/* TODO: known offsets for descriptors. */
GFC_TYPE_ARRAY_OFFSET (fat_type) = NULL_TREE;
if (dimen == 0)
{
arraytype = build_pointer_type (etype);
if (restricted)
arraytype = build_qualified_type (arraytype, TYPE_QUAL_RESTRICT);
GFC_TYPE_ARRAY_DATAPTR_TYPE (fat_type) = arraytype;
return fat_type;
}
/* We define data as an array with the correct size if possible.
Much better than doing pointer arithmetic. */
if (stride)
@ -2835,8 +2846,11 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
gcc_assert (POINTER_TYPE_P (etype));
etype = TREE_TYPE (etype);
gcc_assert (TREE_CODE (etype) == ARRAY_TYPE);
etype = TREE_TYPE (etype);
/* If the type is not a scalar coarray. */
if (TREE_CODE (etype) == ARRAY_TYPE)
etype = TREE_TYPE (etype);
/* Can't handle variable sized elements yet. */
if (int_size_in_bytes (etype) <= 0)
return false;

7
gcc/testsuite/ChangeLog
View file

@ -1,3 +1,10 @@
2011-07-11 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/coarray_14.f90: Remove dg-error "sorry not implemented".
* gfortran.dg/coarray_7.f90: Ditto.
* gfortran.dg/coarray/scalar_alloc_1.f90: New.
* gfortran.dg/coarray/scalar_alloc_2.f90: New.
2011-07-16 Bernd Schmidt <bernds@codesourcery.com>
* gcc.c-torture/execute/ieee/mul-subnormal-single-1.x: Add tic6x-*-*

68
gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 Normal file
View file

@ -0,0 +1,68 @@
! { dg-do run }
!
implicit none
integer, allocatable :: A[:], B[:,:]
integer :: n1, n2, n3
if (allocated (a)) call abort ()
if (allocated (b)) call abort ()
allocate(a[*])
a = 5 + this_image ()
if (a[this_image ()] /= 5 + this_image ()) call abort
a[this_image ()] = 8 - 2*this_image ()
if (a[this_image ()] /= 8 - 2*this_image ()) call abort
if (lcobound(a, dim=1) /= 1 .or. ucobound(a,dim=1) /= num_images()) &
call abort ()
deallocate(a)
allocate(a[4:*])
a[this_image ()] = 8 - 2*this_image ()
if (lcobound(a, dim=1) /= 4 .or. ucobound(a,dim=1) /= 3 + num_images()) &
call abort ()
n1 = -1
n2 = 5
n3 = 3
allocate (B[n1:n2, n3:*])
if (any (lcobound(b) /= [-1, 3]) .or. lcobound(B, dim=2) /= n3) &
call abort()
call sub(A, B)
if (allocated (a)) call abort ()
if (.not.allocated (b)) call abort ()
call two(.true.)
call two(.false.)
! automatically deallocate "B"
contains
subroutine sub(x, y)
integer, allocatable :: x[:], y[:,:]
if (any (lcobound(y) /= [-1, 3]) .or. lcobound(y, dim=2) /= n3) &
call abort()
if (lcobound(x, dim=1) /= 4 .or. ucobound(x,dim=1) /= 3 + num_images()) &
call abort ()
if (x[this_image ()] /= 8 - 2*this_image ()) call abort
deallocate(x)
end subroutine sub
subroutine two(init)
logical, intent(in) :: init
integer, allocatable, SAVE :: a[:]
if (init) then
if (allocated(a)) call abort()
allocate(a[*])
a = 45
else
if (.not. allocated(a)) call abort()
if (a /= 45) call abort()
deallocate(a)
end if
end subroutine two
end

60
gcc/testsuite/gfortran.dg/coarray/scalar_alloc_2.f90 Normal file
View file

@ -0,0 +1,60 @@
! { dg-do run }
!
! Check whether registering allocatable coarrays works
!
type position
real :: x, y, z
end type position
integer, allocatable :: a[:]
type(position), allocatable :: p[:]
allocate(a[*])
a = 7
allocate(p[*])
p%x = 11
p%y = 13
p%z = 15
if (a /= 7) call abort()
a = 88
if (a /= 88) call abort()
if (p%x /= 11) call abort()
p%x = 17
if (p%x /= 17) call abort()
block
integer, allocatable :: b[:]
allocate(b[*])
b = 8494
if (b /= 8494) call abort()
end block
if (a /= 88) call abort()
call test ()
end
subroutine test()
type velocity
real :: x, y, z
end type velocity
real, allocatable :: z[:]
type(velocity), allocatable :: v[:]
allocate(z[*])
z = sqrt(2.0)
allocate(v[*])
v%x = 21
v%y = 23
v%z = 25
if (z /= sqrt(2.0)) call abort()
if (v%x /= 21) call abort()
end subroutine test

2
gcc/testsuite/gfortran.dg/coarray_14.f90
View file

@ -49,7 +49,7 @@ type t
end type t
type(t), allocatable :: a[:]
allocate (t :: a) ! { dg-error "Coarray specification required in ALLOCATE statement" }
allocate (t :: a[*]) ! { dg-error "allocatable scalar coarrays are not yet supported" }
allocate (t :: a[*]) ! OK
end program myTest
! { dg-final { cleanup-modules "m" } }

8
gcc/testsuite/gfortran.dg/coarray_7.f90
View file

@ -90,7 +90,7 @@ 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(c[*]) ! OK
allocate(a%a(5)) ! OK
end subroutine alloc
@ -151,9 +151,9 @@ subroutine allocateTest()
integer :: n, q
n = 1
q = 1
allocate(a[q,*]) ! { dg-error "Sorry" }
allocate(b[q,*]) ! { dg-error "Sorry" }
allocate(c[q,*]) ! { dg-error "Sorry" }
allocate(a[q,*]) ! OK
allocate(b[q,*]) ! OK
allocate(c[q,*]) ! OK
end subroutine allocateTest