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.cc85
1 files changed, 57 insertions, 28 deletions
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 62dd38d..082987f 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"))
@@ -8147,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);
@@ -9836,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);
@@ -10909,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. */
@@ -12849,11 +12875,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
if (gfc_is_reallocatable_lhs (expr1))
{
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;
@@ -12917,6 +12939,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. */
@@ -12935,8 +12958,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))
@@ -12985,6 +13012,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);
}
@@ -13293,15 +13329,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;
generated by cgit v1.1 at 2025-07-15 22:38:00 +0000