diff options
Diffstat (limited to 'gcc/fortran/resolve.c')
| -rw-r--r-- | gcc/fortran/resolve.c | 86 |
1 files changed, 79 insertions, 7 deletions
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 15c9463..241b85e 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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); |