procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

gfortran.h (gfc_isym_id): Add GFC_ISYM_CAF_GET and GFC_ISYM_CAF_SEND.

Browse source 
2014-05-08  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.

From-SVN: r210225
This commit is contained in:
Tobias Burnus 2014-05-08 19:00:07 +02:00 • committed by Tobias Burnus
parent 9c980a137c
commit 8a8d1a16c7
4 changed files with 115 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
gcc/fortran/ChangeLog
View file

@ -1,3 +1,20 @@
2014-05-08 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.
2014-05-08 Tobias Burnus <burnus@net-b.de>
* trans-intrinsic.c (conv_co_minmaxsum): Change condition style.

2
gcc/fortran/gfortran.h
View file

@ -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,

18
gcc/fortran/intrinsic.c
View file

@ -2756,7 +2756,7 @@ add_functions (void)
make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
/* 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,
BT_INTEGER, gfc_index_integer_kind, GFC_STD_GNU,
NULL, NULL, gfc_resolve_stride,
@ -2994,6 +2994,13 @@ add_functions (void)
x, BT_UNKNOWN, 0, REQUIRED);
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();
}
@ -3235,6 +3242,15 @@ add_subroutines (void)
stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
/* 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. */
add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,

86
gcc/fortran/resolve.c
View file

@ -4730,6 +4730,50 @@ done:
}
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
@ -5009,6 +5053,12 @@ resolve_procedure:
}
}
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;
}
@ -6092,11 +6142,7 @@ gfc_resolve_expr (gfc_expr *e)
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)
@ -9214,8 +9260,10 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
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);
@ -9223,6 +9271,25 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
}
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;
}
@ -9845,6 +9912,11 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
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;
@ -9858,7 +9930,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
}
/* 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);