diff options
Diffstat (limited to 'gcc/fortran/trans-expr.c')
| -rw-r--r-- | gcc/fortran/trans-expr.c | 79 |
1 files changed, 79 insertions, 0 deletions
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 0702713..1a48e73 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4919,6 +4919,52 @@ expr_may_alias_variables (gfc_expr *e, bool array_may_alias) } +/* A helper function to set the dtype for unallocated or unassociated + entities. */ + +static void +set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e) +{ + tree tmp; + tree desc; + tree cond; + tree type; + stmtblock_t block; + + /* TODO Figure out how to handle optional dummies. */ + if (e && e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.optional) + return; + + desc = parmse->expr; + if (desc == NULL_TREE) + return; + + if (POINTER_TYPE_P (TREE_TYPE (desc))) + desc = build_fold_indirect_ref_loc (input_location, desc); + + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))) + return; + + gfc_init_block (&block); + tmp = gfc_conv_descriptor_data_get (desc); + cond = fold_build2_loc (input_location, EQ_EXPR, + logical_type_node, tmp, + build_int_cst (TREE_TYPE (tmp), 0)); + tmp = gfc_conv_descriptor_dtype (desc); + type = gfc_get_element_type (TREE_TYPE (desc)); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + TREE_TYPE (tmp), tmp, + gfc_get_dtype_rank_type (e->rank, type)); + gfc_add_expr_to_block (&block, tmp); + cond = build3_v (COND_EXPR, cond, + gfc_finish_block (&block), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&parmse->pre, cond); +} + + + /* Provide an interface between gfortran array descriptors and the F2018:18.4 ISO_Fortran_binding array descriptors. */ @@ -4958,6 +5004,15 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) parmse->expr = build_fold_indirect_ref_loc (input_location, parmse->expr); + /* Unallocated allocatable arrays and unassociated pointer arrays + need their dtype setting if they are argument associated with + assumed rank dummies. */ + if (fsym && fsym->as + && fsym->as->type == AS_ASSUMED_RANK + && (gfc_expr_attr (e).pointer + || gfc_expr_attr (e).allocatable)) + set_dtype_for_unallocated (parmse, e); + /* All the temporary descriptors are marked as DECL_ARTIFICIAL. If the expression type is different from the descriptor type, then the offset must be found (eg. to a component ref or substring) @@ -5953,6 +6008,30 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym, sym->name, NULL); + /* Unallocated allocatable arrays and unassociated pointer arrays + need their dtype setting if they are argument associated with + assumed rank dummies. */ + if (!sym->attr.is_bind_c && e && fsym && fsym->as + && fsym->as->type == AS_ASSUMED_RANK) + { + if (gfc_expr_attr (e).pointer + || gfc_expr_attr (e).allocatable) + set_dtype_for_unallocated (&parmse, e); + else if (e->expr_type == EXPR_VARIABLE + && e->symtree->n.sym->attr.dummy + && e->symtree->n.sym->as + && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE) + { + tree minus_one; + tmp = build_fold_indirect_ref_loc (input_location, + parmse.expr); + minus_one = build_int_cst (gfc_array_index_type, -1); + gfc_conv_descriptor_ubound_set (&parmse.pre, tmp, + gfc_rank_cst[e->rank - 1], + minus_one); + } + } + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ if (fsym && fsym->attr.allocatable |