+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
* 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
}
+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)
{
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;
}
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 *);
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;
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;
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;
}
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;
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
{
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;
{
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)
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))
{
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)
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);
&& (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
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);
}
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);
&& (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);
}
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)
{
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;
/* 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)
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;
+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-*-*
--- /dev/null
+! { 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
--- /dev/null
+! { 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
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" } }
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
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
projects / gcc.git / commitdiff