Add offset to allocatable shared coarrays.

This adds the calculation of the offset for allocatable coarrays,
which was missing before, and fixes the resulting fallout for
ALLOCATED.  Additionally, it prepares the way for STAT and ERRMSG
for ALLOCATE of coarrays, but that still needs changes to
gfc_trans_allocate.

gcc/fortran/ChangeLog:

	* trans-array.c (gfc_conv_array_ref): If se->address_only is set,
	throw away all the offset calculation.
	(gfc_allocate_shared_coarray): Add arguments stat, errmsg and
	errlen to call to allocate.  Calculate offset for allocatable
	coarrays.
	(gfc_array_allocate): Adjust call to gfc_allocate_shared_coarray.
	* trans-array.h (gfc_allocate_shared_coarray): Change prototype
	of cas_coarray_alloc.
	* trans-decl.c (gfc_build_builtin_function_decls): Adjust
	cas_coarray_alloc to changed prototypes.
	(gfc_trans_shared_coarray): Adjust call to gfc_allocate_shared_coarray.
	* trans-intrinsic.c (gfc_conv_allocated): Set address_only on se.
	* trans.h: Add flag address_only to gfc_se.

libgfortran/ChangeLog:

	* caf_shared/wrapper.c (cas_coarray_alloc): Add status, error and
	errmsg arguments and their checking.

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 39e6b6d9051d40613c96abcd2d92e63c6e2106bc..35afff5845e537d68aa3f199e849e6055f6617bc 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3865,8 +3865,7 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
       add_to_offset (&cst_offset, &offset, tmp);
     }
 
-  if (flag_coarray == GFC_FCOARRAY_SHARED && need_impl_this_image
-      && !se->no_impl_this_image)
+  if (flag_coarray == GFC_FCOARRAY_SHARED && need_impl_this_image)
     {
       tree off;
       tree co_stride = gfc_conv_array_stride (decl, eff_dimen + 1);
@@ -3934,6 +3933,15 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_expr *expr,
        decl = NULL_TREE;
     }
 
+  /* Early return - only taken for ALLOCATED for shared coarrays.
+     FIXME - this could probably be done more elegantly.  */
+  if (se->address_only)
+    {
+      se->expr = build_array_ref (se->expr, build_int_cst (TREE_TYPE (offset), 0),
+                                 decl, se->class_vptr);
+      return;
+    }
+
   se->expr = build_array_ref (se->expr, offset, decl, se->class_vptr);
 }
 
@@ -5975,15 +5983,41 @@ gfc_cas_get_allocation_type (gfc_symbol * sym)
 }
 
 void
-gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int corank,
-                           int alloc_type)
+gfc_allocate_shared_coarray (stmtblock_t *b, tree decl, tree size, int rank,
+                            int corank, int alloc_type, tree status,
+                            tree errmsg, tree errlen, bool calc_offset)
 {
+  tree st, err, elen;
+
+  if (status == NULL_TREE)
+    st = null_pointer_node;
+  else
+    st = gfc_build_addr_expr (NULL, status);
+
+  err = errmsg == NULL_TREE ? null_pointer_node : errmsg;
+  elen = errlen == NULL_TREE ? build_int_cst (gfc_charlen_type_node, 0) : errlen;
   gfc_add_expr_to_block (b,
        build_call_expr_loc (input_location, gfor_fndecl_cas_coarray_allocate,
-                           4, gfc_build_addr_expr (pvoid_type_node, decl),
-                           size, build_int_cst (integer_type_node, corank),
-                           build_int_cst (integer_type_node, alloc_type)));
-
+                            7, gfc_build_addr_expr (pvoid_type_node, decl),
+                            size, build_int_cst (integer_type_node, corank),
+                            build_int_cst (integer_type_node, alloc_type),
+                            st, err, elen));
+  if (calc_offset)
+    {
+      int i;
+      tree offset, stride, lbound, mult;
+      offset = build_int_cst (gfc_array_index_type, 0);
+      for (i = 0; i < rank + corank; i++)
+       {
+         stride = gfc_conv_array_stride (decl, i);
+         lbound = gfc_conv_array_lbound (decl, i);
+         mult = fold_build2_loc (input_location, MULT_EXPR,
+                                 gfc_array_index_type, stride, lbound);
+         offset = fold_build2_loc (input_location, MINUS_EXPR,
+                                   gfc_array_index_type, offset, mult);
+       }
+      gfc_conv_descriptor_offset_set (b, decl, offset);
+    }
 }
 
 /* Initializes the descriptor and generates a call to _gfor_allocate.  Does
@@ -6193,7 +6227,9 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
       int alloc_type
             = gfc_cas_get_allocation_type (expr->symtree->n.sym);
       gfc_allocate_shared_coarray (&elseblock, se->expr, elem_size,
-                                  ref->u.ar.as->corank, alloc_type);
+                                  ref->u.ar.as->rank, ref->u.ar.as->corank,
+                                  alloc_type, status, errmsg, errlen,
+                                  true);
     }
   /* The allocatable variant takes the old pointer as first argument.  */
   else if (allocatable)

diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 66f59bb068ba0be15b4ecaaf0ba407c201d16df9..2168e9dc9015a88e53fb60fe444fe9761b4a4973 100644 (file)
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -31,7 +31,8 @@ enum gfc_coarray_allocation_type {
 
 int gfc_cas_get_allocation_type (gfc_symbol *);
 
-void gfc_allocate_shared_coarray (stmtblock_t *, tree, tree, int, int);
+void gfc_allocate_shared_coarray (stmtblock_t *, tree, tree, int, int, int,
+                                 tree, tree, 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-decl.c b/gcc/fortran/trans-decl.c
index 91a5dca0c7f0c8564b249e924b2d1f201f5a0bc9..f3526db7ea6371bb9602ed28c5b94c69fc50afa0 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -4118,9 +4118,15 @@ gfc_build_builtin_function_decls (void)
         get_identifier (PREFIX("cas_master")), ". r ", integer_type_node, 1,
        build_pointer_type (build_function_type_list (void_type_node, NULL_TREE)));
       gfor_fndecl_cas_coarray_allocate = gfc_build_library_function_decl_with_spec (
-        get_identifier (PREFIX("cas_coarray_alloc")), ". . R R R ", integer_type_node, 4,
-       pvoid_type_node, integer_type_node, integer_type_node, integer_type_node,
-       NULL_TREE);
+        get_identifier (PREFIX("cas_coarray_alloc")), ". . R R R W W . ", integer_type_node, 7,
+        pvoid_type_node,       /* desc.  */
+        size_type_node,        /* elem_size.  */
+        integer_type_node,     /* corank.  */
+        integer_type_node,     /* alloc_type.  */
+        pvoid_type_node,       /* stat.  */
+        pvoid_type_node,       /* errmsg.  */
+        gfc_charlen_type_node, /* errmsg_len.  */
+        NULL_TREE);
       gfor_fndecl_cas_coarray_free = gfc_build_library_function_decl_with_spec (
         get_identifier (PREFIX("cas_coarray_free")), ". . R ", integer_type_node, 2,
         pvoid_type_node, /* Pointer to the descriptor to be deallocated.  */
@@ -4689,10 +4695,13 @@ gfc_trans_shared_coarray (stmtblock_t * init, stmtblock_t *cleanup, gfc_symbol *
                           init, &overflow,
                           NULL_TREE, &nelems, NULL,
                           NULL_TREE, true, NULL, &element_size);
-      gfc_conv_descriptor_offset_set (init, decl, offset);
       elem_size = size_in_bytes (gfc_get_element_type (TREE_TYPE(decl)));
-      gfc_allocate_shared_coarray (init, decl, elem_size, sym->as->corank,
-                                 alloc_type);
+      gfc_allocate_shared_coarray (init, decl, elem_size, sym->as->rank,
+                                  sym->as->corank, alloc_type, null_pointer_node,
+                                  null_pointer_node,
+                                  build_int_cst (gfc_charlen_type_node, 0),
+                                  false);
+      gfc_conv_descriptor_offset_set (init, decl, offset);
     }
 
   if (cleanup)

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index e93cd3a12c7f1857c4aaf360ff1f48589d6ce55f..912c9b03a749198a475ffd314da3920701ab1f00 100644 (file)
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -8832,7 +8832,7 @@ gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
        {
          /* Allocatable scalar.  */
          arg1se.want_pointer = 1;
-         arg1se.no_impl_this_image = 1;
+         arg1se.address_only = 1;
          gfc_conv_expr (&arg1se, arg1->expr);
          tmp = arg1se.expr;
        }

diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index f3cf33b342f41de8abae959ffeaa5c2977b3ff5b..d3340b302ad87c9d5918bd58a201c78a904a84c8 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -98,10 +98,9 @@ typedef struct gfc_se
      arrays in gfc_conv_expr_descriptor.  */
   unsigned use_offset:1;
 
-  /* For shared coarrays, do not add the offset for the implied
-     this_image().  */
-
-  unsigned no_impl_this_image:1;
+  /* Set if an array reference should be converted to an address of
+     its data pointer only.  */
+  unsigned address_only:1;
 
   unsigned want_coarray:1;
 

diff --git a/gcc/testsuite/gfortran.dg/caf-shared/coarray_allocate_3.f08 b/gcc/testsuite/gfortran.dg/caf-shared/coarray_allocate_3.f08
new file mode 100644 (file)
index 0000000..bb9b5f1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/caf-shared/coarray_allocate_3.f08
@@ -0,0 +1,27 @@
+! { dg-do run }
+! { dg-set-target-env-var GFORTRAN_NUM_IMAGES "4" }
+! Contributed by Ian Harvey  <ian_harvey@bigpond.com>
+! Extended by Andre Vehreschild  <vehre@gcc.gnu.org>
+! to test that coarray references in allocate work now
+! PR fortran/67451
+
+  program main
+    implicit none
+    type foo
+      integer :: bar = 99
+    end type
+    class(foo), dimension(:), allocatable :: foobar[:]
+    class(foo), dimension(:), allocatable :: some_local_object
+    allocate(foobar(10)[*])
+
+    allocate(some_local_object, source=foobar)
+
+    if (.not. allocated(foobar)) STOP 1
+    if (lbound(foobar, 1) /= 1 .OR. ubound(foobar, 1) /= 10) STOP 2
+    if (.not. allocated(some_local_object)) STOP 3
+    if (any(some_local_object(:)%bar /= [99, 99,  99, 99, 99, 99, 99, 99, 99, 99])) STOP 4
+
+    deallocate(some_local_object)
+    deallocate(foobar)
+  end program
+

diff --git a/libgfortran/caf_shared/wrapper.c b/libgfortran/caf_shared/wrapper.c
index 471619441c0ca20a8adf1af9fb45071048d8c86c..a3d88660f01e4967772f82150503c4f4628e8d62 100644 (file)
--- a/libgfortran/caf_shared/wrapper.c
+++ b/libgfortran/caf_shared/wrapper.c
@@ -44,7 +44,8 @@ enum gfc_coarray_allocation_type
   GFC_NCA_EVENT_COARRAY,
 };
 
-void cas_coarray_alloc (gfc_array_void *, int, int, int);
+void cas_coarray_alloc (gfc_array_void *, size_t, int, int, int *,
+                       char *, size_t);
 export_proto (cas_coarray_alloc);
 
 void cas_coarray_free (gfc_array_void *, int);
@@ -85,8 +86,8 @@ void cas_collsub_broadcast_scalar (void *restrict, size_t, int, int *, char *,
 export_proto (cas_collsub_broadcast_scalar);
 
 void
-cas_coarray_alloc (gfc_array_void *desc, int elem_size, int corank,
-                  int alloc_type)
+cas_coarray_alloc (gfc_array_void *desc, size_t elem_size, int corank,
+                  int alloc_type, int *status, char *errmsg, size_t errmsg_len)
 {
   int i, last_rank_index;
   int num_coarray_elems, num_elems; /* Excludes the last dimension, because it
@@ -98,6 +99,7 @@ cas_coarray_alloc (gfc_array_void *desc, int elem_size, int corank,
   ensure_initialization (); /* This function might be the first one to be
                               called, if it is called in a constructor.  */
 
+  STAT_ERRMSG_ENTRY_CHECK (status, errmsg, errmsg_len);
   if (alloc_type == GFC_NCA_LOCK_COARRAY)
     elem_size = sizeof (pthread_mutex_t);
   else if (alloc_type == GFC_NCA_EVENT_COARRAY)