Fortran: Add caf_is_present_on_remote. [PR107635]

Replace caf_is_present by caf_is_present_on_remote which is using a
dedicated callback for each object to test on the remote image.

gcc/fortran/ChangeLog:

	PR fortran/107635

	* coarray.cc (create_allocated_callback): Add creating remote
	side procedure for checking allocation status of coarray.
	(rewrite_caf_allocated): Rewrite ALLOCATED on coarray to use caf
	routine.
	(coindexed_expr_callback): Exempt caf_is_present_on_remote from
	being rewritten again.
	* gfortran.h (enum gfc_isym_id): Add caf_is_present_on_remote
	id.
	* gfortran.texi: Add documentation for caf_is_present_on_remote.
	* intrinsic.cc (add_functions): Add caf_is_present_on_remote
	symbol.
	* trans-decl.cc (gfc_build_builtin_function_decls): Define
	interface of caf_is_present_on_remote.
	* trans-intrinsic.cc (gfc_conv_intrinsic_caf_is_present_remote):
	Translate caf_is_present_on_remote.
	(trans_caf_is_present): Remove.
	(caf_this_image_ref): Remove.
	(gfc_conv_allocated): Take out coarray treatment, because that
	is rewritten to caf_is_present_on_remote now.
	(gfc_conv_intrinsic_function): Handle caf_is_present_on_remote
	calls.
	* trans.h: Add symbol for caf_is_present_on_remote and remove
	old one.

libgfortran/ChangeLog:

	* caf/libcaf.h (_gfortran_caf_is_present_on_remote): Add new
	function.
	(_gfortran_caf_is_present): Remove deprecated one.
	* caf/single.c (struct accessor_hash_t): Add function ptr access
	for remote side call.
	(_gfortran_caf_is_present_on_remote): Added.
	(_gfortran_caf_is_present): Removed.

gcc/testsuite/ChangeLog:

	* gfortran.dg/coarray/coarray_allocated.f90: Adapt to new method
	of checking on remote image.
	* gfortran.dg/coarray_lib_alloc_4.f90: Same.

1 files changed, 157 insertions, 0 deletions

diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc
index fb21171..c4e637e 100644
--- a/gcc/fortran/coarray.cc
+++ b/gcc/fortran/coarray.cc
@@ -942,6 +942,154 @@ add_caf_get_from_remote (gfc_expr *e)
   free (wrapper);
 }
 
+static gfc_expr *
+create_allocated_callback (gfc_expr *expr)
+{
+  gfc_namespace *ns;
+  gfc_symbol *extproc, *proc, *result, *base, *add_data, *caller_image;
+  char tname[GFC_MAX_SYMBOL_LEN + 1];
+  char *name;
+  const char *mname;
+  gfc_expr *cb, *post_caf_ref_expr;
+  gfc_code *code;
+  gfc_code *backup_caf_accessor_prepend = caf_accessor_prepend;
+  caf_accessor_prepend = nullptr;
+  gfc_expr swp;
+
+  /* Find the top-level namespace.  */
+  for (ns = gfc_current_ns; ns->parent; ns = ns->parent)
+    ;
+
+  if (expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
+    strcpy (tname, expr->value.function.actual->expr->symtree->name);
+  else
+    strcpy (tname, "dummy");
+  if (expr->value.function.actual->expr->symtree->n.sym->module)
+    mname = expr->value.function.actual->expr->symtree->n.sym->module;
+  else
+    mname = "main";
+  name = xasprintf ("_caf_present_%s_%s_%d", mname, tname, ++caf_sym_cnt);
+  gfc_get_symbol (name, ns, &extproc);
+  extproc->declared_at = expr->where;
+  gfc_set_sym_referenced (extproc);
+  ++extproc->refs;
+  gfc_commit_symbol (extproc);
+
+  /* Set up namespace.  */
+  gfc_namespace *sub_ns = gfc_get_namespace (ns, 0);
+  sub_ns->sibling = ns->contained;
+  ns->contained = sub_ns;
+  sub_ns->resolved = 1;
+  /* Set up procedure symbol.  */
+  gfc_find_symbol (name, sub_ns, 1, &proc);
+  sub_ns->proc_name = proc;
+  proc->attr.if_source = IFSRC_DECL;
+  proc->attr.access = ACCESS_PUBLIC;
+  gfc_add_subroutine (&proc->attr, name, NULL);
+  proc->attr.host_assoc = 1;
+  proc->attr.always_explicit = 1;
+  proc->declared_at = expr->where;
+  ++proc->refs;
+  gfc_commit_symbol (proc);
+  free (name);
+
+  split_expr_at_caf_ref (expr->value.function.actual->expr, sub_ns,
+			 &post_caf_ref_expr);
+
+  if (ns->proc_name->attr.flavor == FL_MODULE)
+    proc->module = ns->proc_name->name;
+  gfc_set_sym_referenced (proc);
+  /* Set up formal arguments.  */
+  gfc_formal_arglist **argptr = &proc->formal;
+#define ADD_ARG(name, nsym, stype, skind, sintent)                             \
+  gfc_get_symbol (name, sub_ns, &nsym);                                        \
+  nsym->ts.type = stype;                                                       \
+  nsym->ts.kind = skind;                                                       \
+  nsym->attr.flavor = FL_PARAMETER;                                            \
+  nsym->attr.dummy = 1;                                                        \
+  nsym->attr.intent = sintent;                                                 \
+  nsym->declared_at = expr->where;                                             \
+  gfc_set_sym_referenced (nsym);                                               \
+  *argptr = gfc_get_formal_arglist ();                                         \
+  (*argptr)->sym = nsym;                                                       \
+  argptr = &(*argptr)->next
+
+  name = xasprintf ("add_data_%s_%s_%d", mname, tname, ++caf_sym_cnt);
+  ADD_ARG (name, add_data, BT_DERIVED, 0, INTENT_IN);
+  gfc_commit_symbol (add_data);
+  free (name);
+  ADD_ARG ("caller_image", caller_image, BT_INTEGER, gfc_default_integer_kind,
+	   INTENT_IN);
+  gfc_commit_symbol (caller_image);
+
+  ADD_ARG ("result", result, BT_LOGICAL, gfc_default_logical_kind, INTENT_OUT);
+  gfc_commit_symbol (result);
+
+  // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN);
+  base = post_caf_ref_expr->symtree->n.sym;
+  gfc_set_sym_referenced (base);
+  gfc_commit_symbol (base);
+  *argptr = gfc_get_formal_arglist ();
+  (*argptr)->sym = base;
+  argptr = &(*argptr)->next;
+  gfc_commit_symbol (base);
+#undef ADD_ARG
+
+  /* Set up code.  */
+  /* Code: result = post_caf_ref_expr;  */
+  code = sub_ns->code = gfc_get_code (EXEC_ASSIGN);
+  code->loc = expr->where;
+  code->expr1 = gfc_lval_expr_from_sym (result);
+  swp = *expr;
+  *expr = *swp.value.function.actual->expr;
+  swp.value.function.actual->expr = nullptr;
+  code->expr2 = gfc_copy_expr (&swp);
+  code->expr2->value.function.actual->expr = post_caf_ref_expr;
+
+  remove_caf_ref (code->expr2->value.function.actual->expr, true);
+  add_data->ts.u.derived
+    = create_caf_add_data_parameter_type (post_caf_ref_expr, ns, add_data);
+
+  cb = gfc_lval_expr_from_sym (extproc);
+  cb->ts.interface = extproc;
+
+  if (caf_accessor_prepend)
+    {
+      gfc_code *c = caf_accessor_prepend;
+      /* Find last in chain.  */
+      for (; c->next; c = c->next)
+	;
+      c->next = sub_ns->code;
+      sub_ns->code = caf_accessor_prepend;
+    }
+  caf_accessor_prepend = backup_caf_accessor_prepend;
+  return cb;
+}
+
+static void
+rewrite_caf_allocated (gfc_expr **e)
+{
+  gfc_expr *present_fn_expr, *present_hash_expr, *wrapper;
+
+  present_fn_expr = create_allocated_callback (*e);
+
+  present_hash_expr = gfc_get_expr ();
+  present_hash_expr->expr_type = EXPR_CONSTANT;
+  present_hash_expr->ts.type = BT_INTEGER;
+  present_hash_expr->ts.kind = gfc_default_integer_kind;
+  present_hash_expr->where = (*e)->where;
+  mpz_init_set_ui (present_hash_expr->value.integer,
+		   gfc_hash_value (present_fn_expr->symtree->n.sym));
+  wrapper
+    = gfc_build_intrinsic_call (gfc_current_ns,
+				GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE,
+				"caf_is_present_on_remote", (*e)->where, 3, *e,
+				present_hash_expr, present_fn_expr);
+  gfc_add_caf_accessor (present_hash_expr, present_fn_expr);
+  wrapper->ts = (*e)->ts;
+  *e = wrapper;
+}
+
 static int
 coindexed_expr_callback (gfc_expr **e, int *walk_subtrees,
 			 void *data ATTRIBUTE_UNUSED)
@@ -963,7 +1111,16 @@ coindexed_expr_callback (gfc_expr **e, int *walk_subtrees,
       if ((*e)->value.function.isym)
 	switch ((*e)->value.function.isym->id)
 	  {
+	  case GFC_ISYM_ALLOCATED:
+	    if ((*e)->value.function.actual->expr
+		&& gfc_is_coindexed ((*e)->value.function.actual->expr))
+	      {
+		rewrite_caf_allocated (e);
+		*walk_subtrees = 0;
+	      }
+	    break;
 	  case GFC_ISYM_CAF_GET:
+	  case GFC_ISYM_CAF_IS_PRESENT_ON_REMOTE:
 	    *walk_subtrees = 0;
 	    break;
 	  default: