aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran/trans-expr.cc
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran/trans-expr.cc')
-rw-r--r--gcc/fortran/trans-expr.cc80
1 files changed, 60 insertions, 20 deletions
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index d965539..3e0d763 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -2579,10 +2579,8 @@ gfc_caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
gcc_assert (ref != NULL);
if (ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE)
- {
- return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
- integer_zero_node);
- }
+ return build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
+ null_pointer_node);
img_idx = build_zero_cst (gfc_array_index_type);
extent = build_one_cst (gfc_array_index_type);
@@ -2784,9 +2782,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,
@@ -2797,6 +2797,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. */
@@ -4627,6 +4636,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"))
@@ -6925,10 +6944,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
/* Pass a NULL pointer for an absent arg. */
parmse.expr = null_pointer_node;
+
+ /* Is it an absent character dummy? */
+ bool absent_char = false;
gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
- if (dummy_arg
- && gfc_dummy_arg_get_typespec (*dummy_arg).type
- == BT_CHARACTER)
+
+ /* Fall back to inferred type only if no formal. */
+ if (fsym)
+ absent_char = (fsym->ts.type == BT_CHARACTER);
+ else if (dummy_arg)
+ absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type
+ == BT_CHARACTER);
+ if (absent_char)
parmse.string_length = build_int_cst (gfc_charlen_type_node,
0);
}
@@ -6954,9 +6981,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
|| !CLASS_DATA (fsym)->attr.allocatable));
gfc_init_se (&parmse, NULL);
parmse.expr = null_pointer_node;
- if (arg->associated_dummy
- && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type
- == BT_CHARACTER)
+ if (fsym->ts.type == BT_CHARACTER)
parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
}
else if (fsym && fsym->ts.type == BT_CLASS
@@ -7994,7 +8019,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_add_expr_to_block (&se->post, local_tmp);
}
- if (!finalized && !e->must_finalize)
+ /* Items of array expressions passed to a polymorphic formal arguments
+ create their own clean up, so prevent double free. */
+ if (!finalized && !e->must_finalize
+ && !(e->expr_type == EXPR_ARRAY && fsym
+ && fsym->ts.type == BT_CLASS))
{
bool scalar_res_outside_loop;
scalar_res_outside_loop = e->expr_type == EXPR_FUNCTION
@@ -8137,7 +8166,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
goto end_pointer_check;
tmp = parmse.expr;
- if (fsym && fsym->ts.type == BT_CLASS)
+ if (fsym && fsym->ts.type == BT_CLASS && !attr.proc_pointer)
{
if (POINTER_TYPE_P (TREE_TYPE (tmp)))
tmp = build_fold_indirect_ref_loc (input_location, tmp);
@@ -8401,6 +8430,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
byref = (comp && (comp->attr.dimension
|| (comp->ts.type == BT_CHARACTER && !sym->attr.is_bind_c)))
|| (!comp && gfc_return_by_reference (sym));
+
if (byref)
{
if (se->direct_byref)
@@ -8585,6 +8615,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else if (ts.type == BT_CHARACTER)
vec_safe_push (retargs, len);
}
+
gfc_free_interface_mapping (&mapping);
/* We need to glom RETARGS + ARGLIST + STRINGARGS + APPEND_ARGS. */
@@ -8769,10 +8800,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
/* Transformational functions of derived types with allocatable
components must have the result allocatable components copied when the
- argument is actually given. */
+ argument is actually given. This is unnecessry for REDUCE because the
+ wrapper for the OPERATION function takes care of this. */
arg = expr->value.function.actual;
if (result && arg && expr->rank
&& isym && isym->transformational
+ && isym->id != GFC_ISYM_REDUCE
&& arg->expr
&& arg->expr->ts.type == BT_DERIVED
&& arg->expr->ts.u.derived->attr.alloc_comp)
@@ -9822,7 +9855,12 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm,
&& !cm->attr.proc_pointer)
{
if (cm->attr.allocatable && expr->expr_type == EXPR_NULL)
- gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+ {
+ gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
+ if (cm->attr.codimension && flag_coarray == GFC_FCOARRAY_LIB)
+ gfc_add_modify (&block, gfc_conv_descriptor_token (dest),
+ null_pointer_node);
+ }
else if (cm->attr.allocatable || cm->attr.pdt_array)
{
tmp = gfc_trans_alloc_subarray_assign (dest, cm, expr);
@@ -10895,9 +10933,11 @@ gfc_trans_pointer_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_init_se (&lse, NULL);
/* Usually testing whether this is not a proc pointer assignment. */
- non_proc_ptr_assign = !(gfc_expr_attr (expr1).proc_pointer
- && expr2->expr_type == EXPR_VARIABLE
- && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE);
+ non_proc_ptr_assign
+ = !(gfc_expr_attr (expr1).proc_pointer
+ && ((expr2->expr_type == EXPR_VARIABLE
+ && expr2->symtree->n.sym->attr.flavor == FL_PROCEDURE)
+ || expr2->expr_type == EXPR_NULL));
/* Check whether the expression is a scalar or not; we cannot use
expr1->rank as it can be nonzero for proc pointers. */
generated by cgit v1.1 at 2025-07-12 11:20:32 +0000