2011-07-10 Tobias Burnus * 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. 2011-07-10 Tobias Burnus * 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. diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 6db0836..3bf1e94 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -4126,18 +4126,28 @@ 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) { gfc_ref *ref; 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; } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 328dfbe..eb01b0e 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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 *); diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index b51ae96..07104b8 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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; diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index f4f79f9..4ec892b 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 7383265..55a0fc4 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -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); } diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 88fdcd1..5aa0ca9 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -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) { diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 6d384be..d7f1dd5 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -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; diff --git a/gcc/testsuite/gfortran.dg/coarray_14.f90 b/gcc/testsuite/gfortran.dg/coarray_14.f90 index 3e3f046..49188d6 100644 --- a/gcc/testsuite/gfortran.dg/coarray_14.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_14.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_7.f90 b/gcc/testsuite/gfortran.dg/coarray_7.f90 index 29af0d1..abbd64d 100644 --- a/gcc/testsuite/gfortran.dg/coarray_7.f90 +++ b/gcc/testsuite/gfortran.dg/coarray_7.f90 @@ -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 --- /dev/null 2011-07-10 08:01:05.659884893 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_1.f90 2011-07-10 20:22:18.000000000 +0200 @@ -0,0 +1,50 @@ +! { 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 () + +! 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 +end --- /dev/null 2011-07-10 08:01:05.659884893 +0200 +++ gcc/gcc/testsuite/gfortran.dg/coarray/scalar_alloc_2.f90 2011-07-10 20:18:11.000000000 +0200 @@ -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