diff options
Diffstat (limited to 'gcc/fortran/trans-expr.cc')
| -rw-r--r-- | gcc/fortran/trans-expr.cc | 161 |
1 files changed, 90 insertions, 71 deletions
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index 8d9448e..ec24084 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -714,6 +714,8 @@ gfc_get_class_from_expr (tree expr) { tree tmp; tree type; + bool array_descr_found = false; + bool comp_after_descr_found = false; for (tmp = expr; tmp; tmp = TREE_OPERAND (tmp, 0)) { @@ -725,6 +727,8 @@ gfc_get_class_from_expr (tree expr) { if (GFC_CLASS_TYPE_P (type)) return tmp; + if (GFC_DESCRIPTOR_TYPE_P (type)) + array_descr_found = true; if (type != TYPE_CANONICAL (type)) type = TYPE_CANONICAL (type); else @@ -732,6 +736,23 @@ gfc_get_class_from_expr (tree expr) } if (VAR_P (tmp) || TREE_CODE (tmp) == PARM_DECL) break; + + /* Avoid walking up the reference chain too far. For class arrays, the + array descriptor is a direct component (through a pointer) of the class + container. So there is exactly one COMPONENT_REF between a class + container and its child array descriptor. After seeing an array + descriptor, we can give up on the second COMPONENT_REF we see, if no + class container was found until that point. */ + if (array_descr_found) + { + if (comp_after_descr_found) + { + if (TREE_CODE (tmp) == COMPONENT_REF) + return NULL_TREE; + } + else if (TREE_CODE (tmp) == COMPONENT_REF) + comp_after_descr_found = true; + } } if (POINTER_TYPE_P (TREE_TYPE (tmp))) @@ -2782,9 +2803,11 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, start.expr = gfc_evaluate_now (start.expr, &se->pre); /* Change the start of the string. */ - if ((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE - || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) - && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) + if (((TREE_CODE (TREE_TYPE (se->expr)) == ARRAY_TYPE + || TREE_CODE (TREE_TYPE (se->expr)) == INTEGER_TYPE) + && TYPE_STRING_FLAG (TREE_TYPE (se->expr))) + || (POINTER_TYPE_P (TREE_TYPE (se->expr)) + && TREE_CODE (TREE_TYPE (TREE_TYPE (se->expr))) != ARRAY_TYPE)) tmp = se->expr; else tmp = build_fold_indirect_ref_loc (input_location, @@ -2795,6 +2818,15 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, tmp = gfc_build_array_ref (tmp, start.expr, NULL_TREE, true); se->expr = gfc_build_addr_expr (type, tmp); } + else if (POINTER_TYPE_P (TREE_TYPE (tmp))) + { + tree diff; + diff = fold_build2 (MINUS_EXPR, gfc_charlen_type_node, start.expr, + build_one_cst (gfc_charlen_type_node)); + diff = fold_convert (size_type_node, diff); + se->expr + = fold_build2 (POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp, diff); + } } /* Length = end + 1 - start. */ @@ -4625,6 +4657,16 @@ get_builtin_fn (gfc_symbol * sym) && !strcmp (sym->name, "omp_is_initial_device")) return builtin_decl_explicit (BUILT_IN_OMP_IS_INITIAL_DEVICE); + if (!gfc_option.disable_omp_get_initial_device + && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER + && !strcmp (sym->name, "omp_get_initial_device")) + return builtin_decl_explicit (BUILT_IN_OMP_GET_INITIAL_DEVICE); + + if (!gfc_option.disable_omp_get_num_devices + && flag_openmp && sym->attr.function && sym->ts.type == BT_INTEGER + && !strcmp (sym->name, "omp_get_num_devices")) + return builtin_decl_explicit (BUILT_IN_OMP_GET_NUM_DEVICES); + if (!gfc_option.disable_acc_on_device && flag_openacc && sym->attr.function && sym->ts.type == BT_LOGICAL && !strcmp (sym->name, "acc_on_device_h")) @@ -5443,16 +5485,6 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77, /* Translate the expression. */ gfc_conv_expr (&rse, expr); - /* Reset the offset for the function call since the loop - is zero based on the data pointer. Note that the temp - comes first in the loop chain since it is added second. */ - if (gfc_is_class_array_function (expr)) - { - tmp = loop.ss->loop_chain->info->data.array.descriptor; - gfc_conv_descriptor_offset_set (&loop.pre, tmp, - gfc_index_zero_node); - } - gfc_conv_tmp_array_ref (&lse); if (intent != INTENT_OUT) @@ -7888,21 +7920,21 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, se->ss->info->class_container = arg1_cntnr; } - if (fsym && e) + /* Obtain the character length of an assumed character length procedure + from the typespec of the actual argument. */ + if (e + && parmse.string_length == NULL_TREE + && e->ts.type == BT_PROCEDURE + && e->symtree->n.sym->ts.type == BT_CHARACTER + && e->symtree->n.sym->ts.u.cl->length != NULL + && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) { - /* Obtain the character length of an assumed character length - length procedure from the typespec. */ - if (fsym->ts.type == BT_CHARACTER - && parmse.string_length == NULL_TREE - && e->ts.type == BT_PROCEDURE - && e->symtree->n.sym->ts.type == BT_CHARACTER - && e->symtree->n.sym->ts.u.cl->length != NULL - && e->symtree->n.sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) - { - gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl); - parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl; - } + gfc_conv_const_charlen (e->symtree->n.sym->ts.u.cl); + parmse.string_length = e->symtree->n.sym->ts.u.cl->backend_decl; + } + if (fsym && e) + { /* Obtain the character length for a NULL() actual with a character MOLD argument. Otherwise substitute a suitable dummy length. Here we handle non-optional dummies of non-bind(c) procedures. */ @@ -8138,7 +8170,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, msg = xasprintf ("Pointer actual argument '%s' is not " "associated", e->symtree->n.sym->name); else if (attr.proc_pointer && !e->value.function.actual - && (fsym == NULL || !fsym_attr.proc_pointer)) + && (fsym == NULL + || (!fsym_attr.proc_pointer && !fsym_attr.optional))) msg = xasprintf ("Proc-pointer actual argument '%s' is not " "associated", e->symtree->n.sym->name); else @@ -8821,28 +8854,9 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr)) && expr->must_finalize) { - int n; - if (se->ss && se->ss->loop) - { - gfc_add_block_to_block (&se->ss->loop->pre, &se->pre); - se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre); - tmp = gfc_class_data_get (se->expr); - info->descriptor = tmp; - info->data = gfc_conv_descriptor_data_get (tmp); - info->offset = gfc_conv_descriptor_offset_get (tmp); - for (n = 0; n < se->ss->loop->dimen; n++) - { - tree dim = gfc_rank_cst[n]; - se->ss->loop->to[n] = gfc_conv_descriptor_ubound_get (tmp, dim); - se->ss->loop->from[n] = gfc_conv_descriptor_lbound_get (tmp, dim); - } - } - else - { - /* TODO Eliminate the doubling of temporaries. This - one is necessary to ensure no memory leakage. */ - se->expr = gfc_evaluate_now (se->expr, &se->pre); - } + /* TODO Eliminate the doubling of temporaries. This + one is necessary to ensure no memory leakage. */ + se->expr = gfc_evaluate_now (se->expr, &se->pre); /* Finalize the result, if necessary. */ attr = expr->value.function.esym @@ -12849,16 +12863,19 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_init_se (&lse, NULL); gfc_init_se (&rse, NULL); + gfc_fix_class_refs (expr1); + + realloc_flag = flag_realloc_lhs + && gfc_is_reallocatable_lhs (expr1) + && expr2->rank + && !is_runtime_conformable (expr1, expr2); + /* Walk the lhs. */ lss = gfc_walk_expr (expr1); - if (gfc_is_reallocatable_lhs (expr1)) + if (realloc_flag) { lss->no_bounds_check = 1; - if (!(expr2->expr_type == EXPR_FUNCTION - && expr2->value.function.isym != NULL - && !(expr2->value.function.isym->elemental - || expr2->value.function.isym->conversion))) - lss->is_alloc_lhs = 1; + lss->is_alloc_lhs = 1; } else lss->no_bounds_check = expr1->no_bounds_check; @@ -12906,11 +12923,6 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, assoc_assign = is_assoc_assign (expr1, expr2); - realloc_flag = flag_realloc_lhs - && gfc_is_reallocatable_lhs (expr1) - && expr2->rank - && !is_runtime_conformable (expr1, expr2); - /* Only analyze the expressions for coarray properties, when in coarray-lib mode. Avoid false-positive uninitialized diagnostics with initializing the codimension flag unconditionally. */ @@ -12922,6 +12934,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, rhs_caf_attr = gfc_caf_attr (expr2, false, &rhs_refs_comp); } + tree reallocation = NULL_TREE; if (lss != gfc_ss_terminator) { /* The assignment needs scalarization. */ @@ -12940,8 +12953,12 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, /* Walk the rhs. */ rss = gfc_walk_expr (expr2); if (rss == gfc_ss_terminator) - /* The rhs is scalar. Add a ss for the expression. */ - rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); + { + /* The rhs is scalar. Add a ss for the expression. */ + rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); + lss->is_alloc_lhs = 0; + } + /* When doing a class assign, then the handle to the rhs needs to be a pointer to allow for polymorphism. */ if (is_poly_assign && expr2->rank == 0 && !UNLIMITED_POLY (expr2)) @@ -12990,6 +13007,15 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY; } + /* F2003: Allocate or reallocate lhs of allocatable array. */ + if (realloc_flag) + { + realloc_lhs_warning (expr1->ts.type, true, &expr1->where); + ompws_flags &= ~OMPWS_SCALARIZER_WS; + reallocation = gfc_alloc_allocatable_for_assignment (&loop, expr1, + expr2); + } + /* Start the scalarized loop body. */ gfc_start_scalarized_body (&loop, &body); } @@ -13298,15 +13324,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, gfc_add_expr_to_block (&body, tmp); } - /* F2003: Allocate or reallocate lhs of allocatable array. */ - if (realloc_flag) - { - realloc_lhs_warning (expr1->ts.type, true, &expr1->where); - ompws_flags &= ~OMPWS_SCALARIZER_WS; - tmp = gfc_alloc_allocatable_for_assignment (&loop, expr1, expr2); - if (tmp != NULL_TREE) - gfc_add_expr_to_block (&loop.code[expr1->rank - 1], tmp); - } + if (reallocation != NULL_TREE) + gfc_add_expr_to_block (&loop.code[loop.dimen - 1], reallocation); if (maybe_workshare) ompws_flags &= ~OMPWS_SCALARIZER_BODY; |