2014-05-04 Tobias Burnus <burnus@net-b.de>
* gfortran.h (gfc_isym_id): Add GFC_ISYM_CAF_GET
and GFC_ISYM_CAF_SEND.
* intrinsic.c (add_functions): Add only internally
accessible caf_get and caf_send functions.
* resolve.c (add_caf_get_intrinsic,
remove_caf_get_intrinsic): New functions.
(resolve_variable): Resolve expression rank and
prepare for add_caf_get_intrinsic call.
(gfc_resolve_expr): For variables, remove rank
resolution.
(resolve_ordinary_assign): Prepare call to
GFC_ISYM_CAF_SEND.
(resolve_code): Avoid call to GFC_ISYM_CAF_GET for
the LHS of an assignment.
@@ -2758,3 +2758,3 @@ add_functions (void)
/* Obtain the stride for a given dimensions; to be used only internally.
- "make_from_module" makes inaccessible for external users. */
+ "make_from_module" makes it inaccessible for external users. */
add_sym_2 (GFC_PREFIX ("stride"), GFC_ISYM_STRIDE, CLASS_INQUIRY, ACTUAL_NO,
@@ -2996,2 +2996,9 @@ add_functions (void)
make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
+
+ /* The following function is internally used for coarray libray functions.
+ "make_from_module" makes it inaccessible for external users. */
+ add_sym_1 (GFC_PREFIX ("caf_get"), GFC_ISYM_CAF_GET, CLASS_IMPURE, ACTUAL_NO,
+ BT_REAL, dr, GFC_STD_GNU, NULL, NULL, NULL,
+ x, BT_REAL, dr, REQUIRED);
+ make_from_module();
}
@@ -3237,2 +3244,11 @@ add_subroutines (void)
+ /* The following subroutine is internally used for coarray libray functions.
+ "make_from_module" makes it inaccessible for external users. */
+ add_sym_2s (GFC_PREFIX ("caf_send"), GFC_ISYM_CAF_SEND, CLASS_IMPURE,
+ BT_UNKNOWN, 0, GFC_STD_GNU, NULL, NULL, NULL,
+ "x", BT_REAL, dr, REQUIRED, INTENT_OUT,
+ "y", BT_REAL, dr, REQUIRED, INTENT_IN);
+ make_from_module();
+
+
/* More G77 compatibility garbage. */
@@ -318,6 +318,8 @@ enum gfc_isym_id
GFC_ISYM_BLE,
GFC_ISYM_BLT,
GFC_ISYM_BTEST,
+ GFC_ISYM_CAF_GET,
+ GFC_ISYM_CAF_SEND,
GFC_ISYM_CEILING,
GFC_ISYM_CHAR,
GFC_ISYM_CHDIR,
@@ -4726,14 +4726,58 @@ expression_rank (gfc_expr *e)
e->rank = rank;
done:
expression_shape (e);
}
+static void
+add_caf_get_intrinsic (gfc_expr *e)
+{
+ gfc_expr *wrapper, *tmp_expr;
+ gfc_ref *ref;
+ int n;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+ break;
+ if (ref == NULL)
+ return;
+
+ for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
+ if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
+ return;
+
+ tmp_expr = XCNEW (gfc_expr);
+ *tmp_expr = *e;
+ wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
+ "caf_get", tmp_expr->where, 1, tmp_expr);
+ wrapper->ts = e->ts;
+ wrapper->rank = e->rank;
+ if (e->rank)
+ wrapper->shape = gfc_copy_shape (e->shape, e->rank);
+ *e = *wrapper;
+ free (wrapper);
+}
+
+
+static void
+remove_caf_get_intrinsic (gfc_expr *e)
+{
+ gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym
+ && e->value.function.isym->id == GFC_ISYM_CAF_GET);
+ gfc_expr *e2 = e->value.function.actual->expr;
+ e->value.function.actual->expr =NULL;
+ gfc_free_actual_arglist (e->value.function.actual);
+ gfc_free_shape (&e->shape, e->rank);
+ *e = *e2;
+ free (e2);
+}
+
+
/* Resolve a variable expression. */
static bool
resolve_variable (gfc_expr *e)
{
gfc_symbol *sym;
bool t;
@@ -5005,14 +5049,20 @@ resolve_procedure:
"subcomponent at %L", &e->where);
t = false;
break;
}
}
}
+ if (t)
+ expression_rank (e);
+
+ if (0 && t && gfc_option.coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
+ add_caf_get_intrinsic (e);
+
return t;
}
/* Checks to see that the correct symbol has been host associated.
The only situation where this arises is that in which a twice
contained function is parsed after the host association is made.
@@ -6088,19 +6138,15 @@ gfc_resolve_expr (gfc_expr *e)
case EXPR_FUNCTION:
case EXPR_VARIABLE:
if (check_host_association (e))
t = resolve_function (e);
else
- {
- t = resolve_variable (e);
- if (t)
- expression_rank (e);
- }
+ t = resolve_variable (e);
if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
&& e->ref->type != REF_SUBSTRING)
gfc_resolve_substring_charlen (e);
break;
@@ -9210,23 +9256,44 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
{
gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
"assignment at %L - check that there is a matching specific "
"subroutine for '=' operator", &lhs->where);
return false;
}
+ bool lhs_coindexed = gfc_is_coindexed (lhs);
+
/* F2008, Section 7.2.1.2. */
- if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
+ if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs))
{
gfc_error ("Coindexed variable must not have an allocatable ultimate "
"component in assignment at %L", &lhs->where);
return false;
}
gfc_check_assign (lhs, rhs, 1);
+
+ if (0 && lhs_coindexed && gfc_option.coarray == GFC_FCOARRAY_LIB)
+ {
+ code->op = EXEC_CALL;
+ gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true);
+ code->resolved_sym = code->symtree->n.sym;
+ code->resolved_sym->attr.flavor = FL_PROCEDURE;
+ code->resolved_sym->attr.intrinsic = 1;
+ code->resolved_sym->attr.subroutine = 1;
+ code->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
+ gfc_commit_symbol (code->resolved_sym);
+ code->ext.actual = gfc_get_actual_arglist ();
+ code->ext.actual->expr = lhs;
+ code->ext.actual->next = gfc_get_actual_arglist ();
+ code->ext.actual->next->expr = rhs;
+ code->expr1 = NULL;
+ code->expr2 = NULL;
+ }
+
return false;
}
/* Add a component reference onto an expression. */
static void
@@ -9841,28 +9908,33 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
case EXEC_END_PROCEDURE:
break;
case EXEC_ASSIGN:
if (!t)
break;
+ if (code->expr1->expr_type == EXPR_FUNCTION
+ && code->expr1->value.function.isym
+ && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
+ remove_caf_get_intrinsic (code->expr1);
+
if (!gfc_check_vardef_context (code->expr1, false, false, false,
_("assignment")))
break;
if (resolve_ordinary_assign (code, ns))
{
if (code->op == EXEC_COMPCALL)
goto compcall;
else
goto call;
}
/* F03 7.4.1.3 for non-allocatable, non-pointer components. */
- if (code->expr1->ts.type == BT_DERIVED
+ if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
&& code->expr1->ts.u.derived->attr.defined_assign_comp)
generate_component_assignments (&code, ns);
break;
case EXEC_LABEL_ASSIGN:
if (code->label1->defined == ST_LABEL_UNKNOWN)