trans.h (gfc_caf_get_image_index, [...]): New prototypes.

2014-08-30  Tobias Burnus  <burnus@net-b.de>

        * trans.h (gfc_caf_get_image_index,
        gfc_get_caf_token_offset): New prototypes.
        * trans-expr.c (gfc_caf_get_image_index): Moved from
        trans-intrinsic.c and renamed.
        (gfc_get_caf_token_offset) Ditto; support offset = NULL
        with early return.
        * trans-intrinsic.c (get_caf_token_offset, caf_get_image_index):
        Moved to trans-expr.
        (gfc_conv_intrinsic_caf_get, conv_caf_send,
        conv_intrinsic_atomic_op, conv_intrinsic_atomic_ref,
        conv_intrinsic_atomic_cas): Update callers.

From-SVN: r214758

gcc/fortran/trans-expr.c

@@ -1444,6 +1444,149 @@ gfc_get_tree_for_caf_expr (gfc_expr *expr)
 }
 
 
+/* Obtain the Coarray token - and optionally also the offset.  */
+
+void
+gfc_get_caf_token_offset (tree *token, tree *offset, tree caf_decl, tree se_expr,
+			  gfc_expr *expr)
+{
+  tree tmp;
+
+  /* Coarray token.  */
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
+    {
+      gcc_assert (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl))
+		    == GFC_ARRAY_ALLOCATABLE
+		  || expr->symtree->n.sym->attr.select_type_temporary);
+      *token = gfc_conv_descriptor_token (caf_decl);
+    }
+  else if (DECL_LANG_SPECIFIC (caf_decl)
+	   && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+    *token = GFC_DECL_TOKEN (caf_decl);
+  else
+    {
+      gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
+		  && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
+      *token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
+    }
+
+  if (offset == NULL)
+    return;
+
+  /* Offset between the coarray base address and the address wanted.  */
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
+      && (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE
+	  || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_POINTER))
+    *offset = build_int_cst (gfc_array_index_type, 0);
+  else if (DECL_LANG_SPECIFIC (caf_decl)
+	   && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
+    *offset = GFC_DECL_CAF_OFFSET (caf_decl);
+  else if (GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl)) != NULL_TREE)
+    *offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
+  else
+    *offset = build_int_cst (gfc_array_index_type, 0);
+
+  if (POINTER_TYPE_P (TREE_TYPE (se_expr))
+      && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (se_expr))))
+    {
+      tmp = build_fold_indirect_ref_loc (input_location, se_expr);
+      tmp = gfc_conv_descriptor_data_get (tmp);
+    }
+  else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se_expr)))
+    tmp = gfc_conv_descriptor_data_get (se_expr);
+  else
+    {
+      gcc_assert (POINTER_TYPE_P (TREE_TYPE (se_expr)));
+      tmp = se_expr;
+    }
+
+  *offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			     *offset, fold_convert (gfc_array_index_type, tmp));
+
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
+    tmp = gfc_conv_descriptor_data_get (caf_decl);
+  else
+   {
+     gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
+     tmp = caf_decl;
+   }
+
+  *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			    fold_convert (gfc_array_index_type, *offset),
+			    fold_convert (gfc_array_index_type, tmp));
+}
+
+
+/* Convert the coindex of a coarray into an image index; the result is
+   image_num =  (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2)+1)*extent(1)
+              + (idx(3)-lcobound(3)+1)*extent(2) + ...  */
+
+tree
+gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
+{
+  gfc_ref *ref;
+  tree lbound, ubound, extent, tmp, img_idx;
+  gfc_se se;
+  int i;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+      break;
+  gcc_assert (ref != NULL);
+
+  img_idx = integer_zero_node;
+  extent = integer_one_node;
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+    for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
+      {
+	gfc_init_se (&se, NULL);
+	gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node);
+	gfc_add_block_to_block (block, &se.pre);
+	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
+	tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			       integer_type_node, se.expr,
+			       fold_convert(integer_type_node, lbound));
+	tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node,
+			       extent, tmp);
+	img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+				   img_idx, tmp);
+	if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
+	  {
+	    ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
+	    extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+	    extent = fold_convert (integer_type_node, extent);
+	  }
+      }
+  else
+    for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
+      {
+	gfc_init_se (&se, NULL);
+	gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node);
+	gfc_add_block_to_block (block, &se.pre);
+	lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
+	lbound = fold_convert (integer_type_node, lbound);
+	tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			       integer_type_node, se.expr, lbound);
+	tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node,
+			       extent, tmp);
+	img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+				   img_idx, tmp);
+	if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
+	  {
+	    ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
+	    ubound = fold_convert (integer_type_node, ubound);
+	    extent = fold_build2_loc (input_location, MINUS_EXPR,
+				      integer_type_node, ubound, lbound);
+	    extent = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+				      extent, integer_one_node);
+	  }
+      }
+  img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+			     img_idx, integer_one_node);
+  return img_idx;
+}
+
+
 /* For each character array constructor subexpression without a ts.u.cl->length,
    replace it by its first element (if there aren't any elements, the length
    should already be set to zero).  */

gcc/fortran/trans.h

@@ -420,6 +420,8 @@ tree gfc_conv_scalar_to_descriptor (gfc_se *, tree, symbol_attribute);
 void gfc_conv_scalar_char_value (gfc_symbol *sym, gfc_se *se, gfc_expr **expr);
 tree gfc_string_to_single_character (tree len, tree str, int kind);
 tree gfc_get_tree_for_caf_expr (gfc_expr *);
+void gfc_get_caf_token_offset (tree *, tree *, tree, tree, gfc_expr *);
+tree gfc_caf_get_image_index (stmtblock_t *, gfc_expr *, tree);
 
 /* Find the decl containing the auxiliary variables for assigned variables.  */
 void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr);