diff options
Diffstat (limited to 'gcc/fortran/trans-expr.c')
| -rw-r--r-- | gcc/fortran/trans-expr.c | 119 |
1 files changed, 117 insertions, 2 deletions
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index c45752e..c3388d7 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4891,6 +4891,102 @@ expr_may_alias_variables (gfc_expr *e, bool array_may_alias) } +/* Provide an interface between gfortran array descriptors and the F2018:18.4 + ISO_Fortran_binding array descriptors. */ + +static void +gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym) +{ + tree tmp; + tree cfi_desc_ptr; + tree gfc_desc_ptr; + tree type; + int attribute; + symbol_attribute attr = gfc_expr_attr (e); + + /* If this is a full array or a scalar, the allocatable and pointer + attributes can be passed. Otherwise it is 'CFI_attribute_other'*/ + attribute = 2; + if (!e->rank || gfc_get_full_arrayspec_from_expr (e)) + { + if (attr.pointer) + attribute = 0; + else if (attr.allocatable) + attribute = 1; + } + + if (e->rank) + { + gfc_conv_expr_descriptor (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) + and the dtype updated. */ + type = gfc_typenode_for_spec (&e->ts); + if (DECL_ARTIFICIAL (parmse->expr) + && type != gfc_get_element_type (TREE_TYPE (parmse->expr))) + { + /* Obtain the offset to the data. */ + gfc_get_dataptr_offset (&parmse->pre, parmse->expr, parmse->expr, + gfc_index_zero_node, true, e); + + /* Update the dtype. */ + gfc_add_modify (&parmse->pre, + gfc_conv_descriptor_dtype (parmse->expr), + gfc_get_dtype_rank_type (e->rank, type)); + } + else if (!is_subref_array (e) && !DECL_ARTIFICIAL (parmse->expr)) + { + /* Make sure that the span is set for expressions where it + might not have been done already. */ + tmp = TREE_TYPE (parmse->expr); + tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp)); + tmp = fold_convert (gfc_array_index_type, tmp); + gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp); + } + } + else + { + gfc_conv_expr (parmse, e); + /* Copy the scalar for INTENT_IN. */ + if (e->expr_type == EXPR_VARIABLE && fsym->attr.intent == INTENT_IN) + parmse->expr = gfc_evaluate_now (parmse->expr, &parmse->pre); + parmse->expr = gfc_conv_scalar_to_descriptor (parmse, + parmse->expr, attr); + } + + /* Set the CFI attribute field. */ + tmp = gfc_conv_descriptor_attribute (parmse->expr); + tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, tmp, + build_int_cst (TREE_TYPE (tmp), attribute)); + gfc_add_expr_to_block (&parmse->pre, tmp); + + /* Now pass the gfc_descriptor by reference. */ + parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr); + + /* Variables to point to the gfc and CFI descriptors. */ + gfc_desc_ptr = parmse->expr; + cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi"); + + /* Allocate the CFI descriptor and fill the fields. */ + tmp = gfc_build_addr_expr (NULL_TREE, cfi_desc_ptr); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_gfc_to_cfi, 2, tmp, gfc_desc_ptr); + gfc_add_expr_to_block (&parmse->pre, tmp); + + /* The CFI descriptor is passed to the bind_C procedure. */ + parmse->expr = cfi_desc_ptr; + + /* Transfer values back to gfc descriptor and free the CFI descriptor. */ + tmp = gfc_build_addr_expr (NULL_TREE, parmse->expr); + tmp = build_call_expr_loc (input_location, + gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp); + gfc_prepend_expr_to_block (&parmse->post, tmp); +} + + /* Generate code for a procedure call. Note can return se->post != NULL. If se->direct_byref is set then se->expr contains the return parameter. Return nonzero, if the call has alternate specifiers. @@ -5234,7 +5330,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tmp = gfc_get_symbol_decl (e->symtree->n.sym->cp_pointer); parmse.expr = convert (type, tmp); } - else if (fsym && fsym->attr.value) + + else if (sym->attr.is_bind_c && e + && fsym && fsym->attr.dimension + && (fsym->as->type == AS_ASSUMED_RANK + || fsym->as->type == AS_ASSUMED_SHAPE)) + /* Implement F2018, C.12.6.1: paragraph (2). */ + gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym); + + else if (fsym && fsym->attr.value) { if (fsym->ts.type == BT_CHARACTER && fsym->ts.is_c_interop @@ -5273,6 +5377,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } } } + else if (arg->name && arg->name[0] == '%') /* Argument list functions %VAL, %LOC and %REF are signalled through arg->name. */ @@ -5287,6 +5392,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_expr (&parmse, e); parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); } + else if (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym->result && e->symtree->n.sym->result != e->symtree->n.sym @@ -5297,6 +5403,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (fsym && fsym->attr.proc_pointer) parmse.expr = gfc_build_addr_expr (NULL_TREE, parmse.expr); } + else { if (e->ts.type == BT_CLASS && fsym @@ -5670,7 +5777,14 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, parmse.force_tmp = 1; } - if (e->expr_type == EXPR_VARIABLE + if (sym->attr.is_bind_c && e + && fsym && fsym->attr.dimension + && (fsym->as->type == AS_ASSUMED_RANK + || fsym->as->type == AS_ASSUMED_SHAPE)) + /* Implement F2018, C.12.6.1: paragraph (2). */ + gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym); + + else if (e->expr_type == EXPR_VARIABLE && is_subref_array (e) && !(fsym && fsym->attr.pointer)) /* The actual argument is a component reference to an @@ -5680,6 +5794,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, fsym ? fsym->attr.intent : INTENT_INOUT, fsym && fsym->attr.pointer); + else if (gfc_is_class_array_ref (e, NULL) && fsym && fsym->ts.type == BT_DERIVED) /* The actual argument is a component reference to an |