gcc/fortran/decl.c | 23 -
gcc/fortran/expr.c | 8 +-
gcc/fortran/gfortran.h | 31 +-
gcc/fortran/interface.c | 15 +
gcc/fortran/trans-array.c | 119 ++++
gcc/fortran/trans-array.h | 13 +
gcc/fortran/trans-decl.c | 624 ++++++++++++++++-----
gcc/fortran/trans-expr.c | 572 ++++++++++++++-----
gcc/fortran/trans-stmt.c | 44 +-
gcc/fortran/trans-types.c | 105 +++-
gcc/fortran/trans-types.h | 3 +-
gcc/fortran/trans.c | 11 +-
gcc/fortran/trans.h | 2 -
.../gfortran.dg/ISO_Fortran_binding_4.f90 | 22 +-
gcc/testsuite/gfortran.dg/PR93963.f90 | 94 +++-
gcc/testsuite/gfortran.dg/assumed_type_12.f90 | 35 ++
gcc/testsuite/gfortran.dg/bind-c-intent-out.f90 | 9 +-
.../gfortran.dg/bind_c_array_params_2.f90 | 30 +-
gcc/testsuite/gfortran.dg/bind_c_char_10.f90 | 25 +-
libgfortran/runtime/ISO_Fortran_binding.c | 4 +
20 files changed, 1402 insertions(+), 387 deletions(-)
@@ -1584,15 +1584,6 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
sym->name, &sym->declared_at,
sym->ns->proc_name->name))
retval = false;
- else if (!sym->attr.dimension)
- {
- /* FIXME: Use CFI array descriptor for scalars. */
- gfc_error ("Sorry, deferred-length scalar character dummy "
- "argument %qs at %L of procedure %qs with "
- "BIND(C) not yet supported", sym->name,
- &sym->declared_at, sym->ns->proc_name->name);
- retval = false;
- }
}
else if (sym->attr.value
&& (!cl || !cl->length
@@ -1614,20 +1605,6 @@ gfc_verify_c_interop_param (gfc_symbol *sym)
"attribute", sym->name, &sym->declared_at,
sym->ns->proc_name->name))
retval = false;
- else if (!sym->attr.dimension
- || sym->as->type == AS_ASSUMED_SIZE
- || sym->as->type == AS_EXPLICIT)
- {
- /* FIXME: Valid - should use the CFI array descriptor, but
- not yet handled for scalars and assumed-/explicit-size
- arrays. */
- gfc_error ("Sorry, character dummy argument %qs at %L "
- "with assumed length is not yet supported for "
- "procedure %qs with BIND(C) attribute",
- sym->name, &sym->declared_at,
- sym->ns->proc_name->name);
- retval = false;
- }
}
else if (cl->length->expr_type != EXPR_CONSTANT)
{
@@ -1078,11 +1078,13 @@ is_CFI_desc (gfc_symbol *sym, gfc_expr *e)
if (sym && sym->attr.dummy
&& sym->ns->proc_name->attr.is_bind_c
- && sym->attr.dimension
&& (sym->attr.pointer
|| sym->attr.allocatable
- || sym->as->type == AS_ASSUMED_SHAPE
- || sym->as->type == AS_ASSUMED_RANK))
+ || (sym->attr.dimension
+ && (sym->as->type == AS_ASSUMED_SHAPE
+ || sym->as->type == AS_ASSUMED_RANK))
+ || (sym->ts.type == BT_CHARACTER
+ && (!sym->ts.u.cl || !sym->ts.u.cl->length))))
return true;
return false;
@@ -48,7 +48,6 @@ not after.
libgfortran/libgfortran_frontend.h */
#include "libgfortran.h"
-
#include "intl.h"
#include "splay-tree.h"
@@ -105,6 +104,36 @@ typedef struct
}
mstring;
+/* ISO_Fortran_binding.h
+ CAUTION: This has to be kept in sync with libgfortran. */
+
+#define CFI_type_kind_shift 8
+#define CFI_type_from_type_kind(t, k) (t + (k << CFI_type_kind_shift))
+
+/* Constants, defined as macros. */
+#define CFI_VERSION 1
+#define CFI_MAX_RANK 15
+
+/* Attributes. */
+#define CFI_attribute_pointer 0
+#define CFI_attribute_allocatable 1
+#define CFI_attribute_other 2
+
+#define CFI_type_mask 0xFF
+#define CFI_type_kind_shift 8
+
+/* Intrinsic types. Their kind number defines their storage size. */
+#define CFI_type_Integer 1
+#define CFI_type_Logical 2
+#define CFI_type_Real 3
+#define CFI_type_Complex 4
+#define CFI_type_Character 5
+
+/* Types with no kind. */
+#define CFI_type_struct 6
+#define CFI_type_cptr 7
+#define CFI_type_cfunptr 8
+#define CFI_type_other -1
/*************************** Enums *****************************/
@@ -2448,6 +2448,21 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
return false;
}
+ /* F2018, C711. */
+ if (actual->ts.type == BT_ASSUMED
+ && formal->attr.dimension
+ && formal->as->type == AS_ASSUMED_RANK
+ && (!actual->symtree->n.sym->attr.dimension
+ || (actual->symtree->n.sym->as->type != AS_ASSUMED_RANK
+ && actual->symtree->n.sym->as->type != AS_ASSUMED_SHAPE)))
+ {
+ if (where)
+ gfc_error ("Assumed-type actual argument at %L must be of assumed rank"
+ " or assumed shape as dummy argument %qs has assumed rank",
+ &actual->where, formal->name);
+ return false;
+ }
+
/* F2008, 12.5.2.5; IR F08/0073. */
if (formal->ts.type == BT_CLASS && formal->attr.class_ok
&& actual->expr_type != EXPR_NULL
@@ -103,6 +103,111 @@ gfc_array_dataptr_type (tree desc)
return (GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc)));
}
+/* Build expressions to access members of the CFI descriptor. */
+#define CFI_FIELD_BASE_ADDR 0
+#define CFI_FIELD_ELEM_LEN 1
+#define CFI_FIELD_VERSION 2
+#define CFI_FIELD_RANK 3
+#define CFI_FIELD_ATTRIBUTE 4
+#define CFI_FIELD_TYPE 5
+#define CFI_FIELD_DIM 6
+
+#define CFI_DIM_FIELD_LOWER_BOUND 0
+#define CFI_DIM_FIELD_EXTENT 1
+#define CFI_DIM_FIELD_SM 2
+
+static tree
+gfc_get_cfi_descriptor_field (tree desc, unsigned field_idx)
+{
+ tree type = TREE_TYPE (desc);
+ gcc_assert (TREE_CODE (type) == RECORD_TYPE
+ && TYPE_FIELDS (type)
+ && (strcmp ("base_addr",
+ IDENTIFIER_POINTER (DECL_NAME (TYPE_FIELDS (type))))
+ == 0));
+ tree field = gfc_advance_chain (TYPE_FIELDS (type), field_idx);
+ gcc_assert (field != NULL_TREE);
+
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ desc, field, NULL_TREE);
+}
+
+tree
+gfc_get_cfi_desc_base_addr (tree desc)
+{
+ return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_BASE_ADDR);
+}
+
+tree
+gfc_get_cfi_desc_elem_len (tree desc)
+{
+ return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ELEM_LEN);
+}
+
+tree
+gfc_get_cfi_desc_version (tree desc)
+{
+ return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_VERSION);
+}
+
+tree
+gfc_get_cfi_desc_rank (tree desc)
+{
+ return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_RANK);
+}
+
+tree
+gfc_get_cfi_desc_type (tree desc)
+{
+ return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_TYPE);
+}
+
+tree
+gfc_get_cfi_desc_attribute (tree desc)
+{
+ return gfc_get_cfi_descriptor_field (desc, CFI_FIELD_ATTRIBUTE);
+}
+
+static tree
+gfc_get_cfi_dim_item (tree desc, tree idx, unsigned field_idx)
+{
+ tree tmp = gfc_get_cfi_descriptor_field (desc, CFI_FIELD_DIM);
+ tmp = gfc_build_array_ref (tmp, idx, NULL);
+ tree field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), field_idx);
+ gcc_assert (field != NULL_TREE);
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
+ tmp, field, NULL_TREE);
+}
+
+tree
+gfc_get_cfi_dim_lbound (tree desc, tree idx)
+{
+ return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_LOWER_BOUND);
+}
+
+tree
+gfc_get_cfi_dim_extent (tree desc, tree idx)
+{
+ return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_EXTENT);
+}
+
+tree
+gfc_get_cfi_dim_sm (tree desc, tree idx)
+{
+ return gfc_get_cfi_dim_item (desc, idx, CFI_DIM_FIELD_SM);
+}
+
+#undef CFI_FIELD_BASE_ADDR
+#undef CFI_FIELD_ELEM_LEN
+#undef CFI_FIELD_VERSION
+#undef CFI_FIELD_RANK
+#undef CFI_FIELD_ATTRIBUTE
+#undef CFI_FIELD_TYPE
+#undef CFI_FIELD_DIM
+
+#undef CFI_DIM_FIELD_LOWER_BOUND
+#undef CFI_DIM_FIELD_EXTENT
+#undef CFI_DIM_FIELD_SM
/* Build expressions to access the members of an array descriptor.
It's surprisingly easy to mess up here, so never access
@@ -288,6 +393,20 @@ gfc_conv_descriptor_attribute (tree desc)
dtype, tmp, NULL_TREE);
}
+tree
+gfc_conv_descriptor_type (tree desc)
+{
+ tree tmp;
+ tree dtype;
+
+ dtype = gfc_conv_descriptor_dtype (desc);
+ tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_TYPE);
+ gcc_assert (tmp!= NULL_TREE
+ && TREE_TYPE (tmp) == signed_char_type_node);
+ return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp),
+ dtype, tmp, NULL_TREE);
+}
+
tree
gfc_get_descriptor_dimension (tree desc)
{
@@ -173,6 +173,7 @@ tree gfc_conv_descriptor_dtype (tree);
tree gfc_conv_descriptor_rank (tree);
tree gfc_conv_descriptor_elem_len (tree);
tree gfc_conv_descriptor_attribute (tree);
+tree gfc_conv_descriptor_type (tree);
tree gfc_get_descriptor_dimension (tree);
tree gfc_conv_descriptor_stride_get (tree, tree);
tree gfc_conv_descriptor_lbound_get (tree, tree);
@@ -186,6 +187,18 @@ void gfc_conv_descriptor_stride_set (stmtblock_t *, tree, tree, tree);
void gfc_conv_descriptor_lbound_set (stmtblock_t *, tree, tree, tree);
void gfc_conv_descriptor_ubound_set (stmtblock_t *, tree, tree, tree);
+/* CFI descriptor. */
+tree gfc_get_cfi_desc_base_addr (tree);
+tree gfc_get_cfi_desc_elem_len (tree);
+tree gfc_get_cfi_desc_version (tree);
+tree gfc_get_cfi_desc_rank (tree);
+tree gfc_get_cfi_desc_type (tree);
+tree gfc_get_cfi_desc_attribute (tree);
+tree gfc_get_cfi_dim_lbound (tree, tree);
+tree gfc_get_cfi_dim_extent (tree, tree);
+tree gfc_get_cfi_dim_sm (tree, tree);
+
+
/* Shift lower bound of descriptor, updating ubound and offset. */
void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
@@ -117,8 +117,6 @@ tree gfor_fndecl_fdate;
tree gfor_fndecl_ttynam;
tree gfor_fndecl_in_pack;
tree gfor_fndecl_in_unpack;
-tree gfor_fndecl_cfi_to_gfc;
-tree gfor_fndecl_gfc_to_cfi;
tree gfor_fndecl_associated;
tree gfor_fndecl_system_clock4;
tree gfor_fndecl_system_clock8;
@@ -1548,6 +1546,14 @@ gfc_get_symbol_decl (gfc_symbol * sym)
|| (sym->module && sym->attr.if_source != IFSRC_DECL
&& sym->backend_decl));
+ if (sym->attr.dummy && sym->ns->proc_name->attr.is_bind_c
+ && is_CFI_desc (sym, NULL))
+ {
+ gcc_assert (sym->backend_decl && (sym->ts.type != BT_CHARACTER
+ || sym->ts.u.cl->backend_decl));
+ return sym->backend_decl;
+ }
+
if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
byref = gfc_return_by_reference (sym->ns->proc_name);
else
@@ -1595,9 +1601,6 @@ gfc_get_symbol_decl (gfc_symbol * sym)
sym->ts.u.cl->backend_decl = build_fold_indirect_ref (sym->ts.u.cl->backend_decl);
}
- if (is_CFI_desc (sym, NULL))
- gfc_defer_symbol_init (sym);
-
fun_or_res = byref && (sym->attr.result
|| (sym->attr.function && sym->ts.deferred));
if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res)
@@ -2755,9 +2758,19 @@ create_function_arglist (gfc_symbol * sym)
if (f->sym->attr.volatile_)
type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
- /* Build the argument declaration. */
- parm = build_decl (input_location,
- PARM_DECL, gfc_sym_identifier (f->sym), type);
+ /* Build the argument declaration. For C descriptors, we use a
+ '_'-prefixed name as the decl inside the proc uses the
+ sym->name. */
+ tree parm_name;
+ if (sym->attr.is_bind_c && is_CFI_desc (f->sym, NULL))
+ {
+ strcpy (&name[1], f->sym->name);
+ name[0] = '_';
+ parm_name = get_identifier (name);
+ }
+ else
+ parm_name = gfc_sym_identifier (f->sym);
+ parm = build_decl (input_location, PARM_DECL, parm_name, type);
if (f->sym->attr.volatile_)
{
@@ -3834,19 +3847,6 @@ gfc_build_builtin_function_decls (void)
get_identifier (PREFIX("internal_unpack")), ". w R ",
void_type_node, 2, pvoid_type_node, pvoid_type_node);
- /* These two builtins write into what the first argument points to and
- read from what the second argument points to, but we can't use R
- for that, because the directly pointed structure contains a pointer
- which is copied into the descriptor pointed by the first argument,
- effectively escaping that way. See PR92123. */
- gfor_fndecl_cfi_to_gfc = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("cfi_desc_to_gfc_desc")), ". w . ",
- void_type_node, 2, pvoid_type_node, ppvoid_type_node);
-
- gfor_fndecl_gfc_to_cfi = gfc_build_library_function_decl_with_spec (
- get_identifier (PREFIX("gfc_desc_to_cfi_desc")), ". w . ",
- void_type_node, 2, ppvoid_type_node, pvoid_type_node);
-
gfor_fndecl_associated = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("associated")), ". R R ",
integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
@@ -4464,115 +4464,6 @@ gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
}
-/* Convert CFI descriptor dummies into gfc types and back again. */
-static void
-convert_CFI_desc (gfc_wrapped_block * block, gfc_symbol *sym)
-{
- tree gfc_desc;
- tree gfc_desc_ptr;
- tree CFI_desc;
- tree CFI_desc_ptr;
- tree dummy_ptr;
- tree tmp;
- tree present;
- tree incoming;
- tree outgoing;
- stmtblock_t outer_block;
- stmtblock_t tmpblock;
-
- /* dummy_ptr will be the pointer to the passed array descriptor,
- while CFI_desc is the descriptor itself. */
- if (DECL_LANG_SPECIFIC (sym->backend_decl))
- CFI_desc = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
- else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (sym->backend_decl))))
- CFI_desc = sym->backend_decl;
- else
- CFI_desc = NULL;
-
- dummy_ptr = CFI_desc;
-
- if (CFI_desc)
- {
- CFI_desc = build_fold_indirect_ref_loc (input_location, CFI_desc);
-
- /* The compiler will have given CFI_desc the correct gfortran
- type. Use this new variable to store the converted
- descriptor. */
- gfc_desc = gfc_create_var (TREE_TYPE (CFI_desc), "gfc_desc");
- tmp = build_pointer_type (TREE_TYPE (gfc_desc));
- gfc_desc_ptr = gfc_create_var (tmp, "gfc_desc_ptr");
- CFI_desc_ptr = gfc_create_var (pvoid_type_node, "CFI_desc_ptr");
-
- /* Fix the condition for the presence of the argument. */
- gfc_init_block (&outer_block);
- present = fold_build2_loc (input_location, NE_EXPR,
- logical_type_node, dummy_ptr,
- build_int_cst (TREE_TYPE (dummy_ptr), 0));
-
- gfc_init_block (&tmpblock);
- /* Pointer to the gfc descriptor. */
- gfc_add_modify (&tmpblock, gfc_desc_ptr,
- gfc_build_addr_expr (NULL, gfc_desc));
- /* Store the pointer to the CFI descriptor. */
- gfc_add_modify (&tmpblock, CFI_desc_ptr,
- fold_convert (pvoid_type_node, dummy_ptr));
- tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
- /* Convert the CFI descriptor. */
- incoming = build_call_expr_loc (input_location,
- gfor_fndecl_cfi_to_gfc, 2, gfc_desc_ptr, tmp);
- gfc_add_expr_to_block (&tmpblock, incoming);
- /* Set the dummy pointer to point to the gfc_descriptor. */
- gfc_add_modify (&tmpblock, dummy_ptr,
- fold_convert (TREE_TYPE (dummy_ptr), gfc_desc_ptr));
-
- /* The hidden string length is not passed to bind(C) procedures so set
- it from the descriptor element length. */
- if (sym->ts.type == BT_CHARACTER
- && sym->ts.u.cl->backend_decl
- && VAR_P (sym->ts.u.cl->backend_decl))
- {
- tmp = build_fold_indirect_ref_loc (input_location, dummy_ptr);
- tmp = gfc_conv_descriptor_elem_len (tmp);
- gfc_add_modify (&tmpblock, sym->ts.u.cl->backend_decl,
- fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl),
- tmp));
- }
-
- /* Check that the argument is present before executing the above. */
- incoming = build3_v (COND_EXPR, present,
- gfc_finish_block (&tmpblock),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&outer_block, incoming);
- incoming = gfc_finish_block (&outer_block);
-
- /* Convert the gfc descriptor back to the CFI type before going
- out of scope, if the CFI type was present at entry. */
- outgoing = NULL_TREE;
- if ((sym->attr.pointer || sym->attr.allocatable)
- && !sym->attr.value
- && sym->attr.intent != INTENT_IN)
- {
- gfc_init_block (&outer_block);
- gfc_init_block (&tmpblock);
-
- tmp = gfc_build_addr_expr (ppvoid_type_node, CFI_desc_ptr);
- outgoing = build_call_expr_loc (input_location,
- gfor_fndecl_gfc_to_cfi, 2,
- tmp, gfc_desc_ptr);
- gfc_add_expr_to_block (&tmpblock, outgoing);
-
- outgoing = build3_v (COND_EXPR, present,
- gfc_finish_block (&tmpblock),
- build_empty_stmt (input_location));
- gfc_add_expr_to_block (&outer_block, outgoing);
- outgoing = gfc_finish_block (&outer_block);
- }
-
- /* Add the lot to the procedure init and finally blocks. */
- gfc_add_init_cleanup (block, incoming, outgoing);
- }
-}
-
/* Get the result expression for a procedure. */
static tree
@@ -5149,13 +5040,6 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
}
else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type)
gcc_unreachable ();
-
- /* Assumed shape and assumed rank arrays are passed to BIND(C) procedures
- as ISO Fortran Interop descriptors. These have to be converted to
- gfortran descriptors and back again. This has to be done here so that
- the conversion occurs at the start of the init block. */
- if (is_CFI_desc (sym, NULL))
- convert_CFI_desc (block, sym);
}
gfc_init_block (&tmpblock);
@@ -6779,6 +6663,399 @@ finish_oacc_declare (gfc_namespace *ns, gfc_symbol *sym, bool block)
return;
}
+static void
+gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally,
+ tree cfi_desc, tree gfc_desc, gfc_symbol *sym)
+{
+ stmtblock_t block;
+ gfc_init_block (&block);
+ tree cfi = build_fold_indirect_ref_loc (input_location, cfi_desc);
+ tree rank, label_loop, label_end, idx, etype, tmp, tmp2;
+
+ /* When allocatable + intent out, free the cfi descriptor. */
+ if (sym->attr.allocatable && sym->attr.intent == INTENT_OUT)
+ {
+ tmp = gfc_get_cfi_desc_base_addr (cfi);
+ tree call = builtin_decl_explicit (BUILT_IN_FREE);
+ call = build_call_expr_loc (input_location, call, 1, tmp);
+ gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
+ gfc_add_modify (&block, tmp,
+ fold_convert (TREE_TYPE (tmp), null_pointer_node));
+ }
+
+ if (!sym->attr.referenced)
+ goto done;
+
+ /* Set string length for len=* and len=:, otherwise, it is already set. */
+ if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length)
+ {
+ tmp = fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi));
+ if (sym->ts.kind != 1)
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ gfc_array_index_type, tmp,
+ build_int_cst (gfc_charlen_type_node,
+ sym->ts.kind));
+ gfc_add_modify (&block, sym->ts.u.cl->backend_decl, tmp);
+ }
+ /* gfc->data = cfi->base_addr - or for scalars: gfc = cfi->base_addr. */
+ if (!sym->attr.dimension)
+ {
+ tmp = gfc_get_cfi_desc_base_addr (cfi);
+ gfc_add_modify (&block, gfc_desc,
+ fold_convert (TREE_TYPE (gfc_desc), tmp));
+ goto done;
+ }
+
+ /* gfc->dtype = ... (from declaration, not from cfi). */
+ etype = gfc_get_element_type (TREE_TYPE (gfc_desc));
+ gfc_add_modify (&block, gfc_conv_descriptor_dtype (gfc_desc),
+ gfc_get_dtype_rank_type (sym->as->rank, etype));
+
+ /* gfc->data = cfi->base_addr. */
+ gfc_conv_descriptor_data_set (&block, gfc_desc,
+ gfc_get_cfi_desc_base_addr (cfi));
+
+ /* -fcheck=bound: Do version, rank, attribute, type and is-NULL checks. */
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ {
+ char *msg;
+ tree tmp3;
+ msg = xasprintf ("Unexpected version %%d (expected %d) in CFI descriptor "
+ "passed to dummy argument %s", CFI_VERSION, sym->name);
+ tmp2 = gfc_get_cfi_desc_version (cfi);
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
+ build_int_cst (TREE_TYPE (tmp2), CFI_VERSION));
+ gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+ msg, tmp2);
+ free (msg);
+
+ msg = xasprintf ("Invalid rank %%d (expected 0..%d) in CFI descriptor "
+ "passed to dummy argument %s", CFI_MAX_RANK, sym->name);
+ tmp3 = tmp2 = tmp = gfc_get_cfi_desc_rank (cfi);
+ tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+ tmp2 = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp2,
+ build_int_cst (TREE_TYPE (tmp2), CFI_MAX_RANK));
+ tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
+ tmp, tmp2);
+ gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+ msg, tmp3);
+ free (msg);
+
+ tmp3 = tmp = gfc_get_cfi_desc_attribute (cfi);
+ if (sym->attr.allocatable || sym->attr.pointer)
+ {
+ int attr = (sym->attr.pointer ? CFI_attribute_pointer
+ : CFI_attribute_allocatable);
+ msg = xasprintf ("Invalid attribute %%d (expected %d) in CFI "
+ "descriptor passed to %s dummy argument %s", attr,
+ sym->attr.pointer ? "pointer" : "allocatable",
+ sym->name);
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, build_int_cst (TREE_TYPE (tmp), attr));
+ }
+ else
+ {
+ int amin = MIN (CFI_attribute_pointer,
+ MIN (CFI_attribute_allocatable, CFI_attribute_other));
+ int amax = MAX (CFI_attribute_pointer,
+ MAX (CFI_attribute_allocatable, CFI_attribute_other));
+ msg = xasprintf ("Invalid attribute %%d (expected %d..%d) in CFI "
+ "descriptor passed to nonallocatable, nonpointer "
+ "dummy argument %s", amin, amax, sym->name);
+ tmp2 = tmp;
+ tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, tmp,
+ build_int_cst (TREE_TYPE (tmp), amin));
+ tmp2 = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp2,
+ build_int_cst (TREE_TYPE (tmp2), amax));
+ tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ boolean_type_node, tmp, tmp2);
+ gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+ msg, tmp3);
+ free (msg);
+ msg = xasprintf ("Invalid unallocatated/unassociated CFI "
+ "descriptor passed to nonallocatable, nonpointer "
+ "dummy argument %s", sym->name);
+ tmp3 = tmp = gfc_get_cfi_desc_base_addr (cfi),
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ tmp, null_pointer_node);
+ }
+ gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+ msg, tmp3);
+ free (msg);
+
+ if (sym->ts.type != BT_ASSUMED)
+ {
+ int type = CFI_type_other;
+ if (sym->ts.f90_type == BT_VOID)
+ {
+ type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
+ ? CFI_type_cfunptr : CFI_type_cptr);
+ }
+ else
+ switch (sym->ts.type)
+ {
+ case BT_INTEGER:
+ case BT_LOGICAL:
+ case BT_REAL:
+ case BT_COMPLEX:
+ type = CFI_type_from_type_kind (sym->ts.type, sym->ts.kind);
+ break;
+ case BT_CHARACTER:
+ type = CFI_type_from_type_kind (sym->ts.type, sym->ts.kind);
+ break;
+ case BT_DERIVED:
+ type = CFI_type_struct;
+ break;
+ case BT_VOID:
+ type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
+ ? CFI_type_cfunptr : CFI_type_cptr);
+ break;
+ case BT_ASSUMED:
+ case BT_CLASS:
+ case BT_PROCEDURE:
+ case BT_HOLLERITH:
+ case BT_UNION:
+ case BT_BOZ:
+ case BT_UNKNOWN:
+ gcc_unreachable ();
+ }
+ msg = xasprintf ("Unexpected type %%d (expected %d) in CFI descriptor"
+ " passed to dummy argument %s", type, sym->name);
+ tmp2 = tmp = gfc_get_cfi_desc_type (cfi);
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, build_int_cst (TREE_TYPE (tmp), type));
+ gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at,
+ msg, tmp2);
+ free (msg);
+ }
+ }
+
+ /* Set gfc->dtype.rank, if assumed-rank. */
+ if (sym->as->rank < 0)
+ {
+ rank = gfc_get_cfi_desc_rank (cfi);
+ gfc_add_modify (&block, gfc_conv_descriptor_rank (gfc_desc), rank);
+ }
+ else
+ rank = build_int_cst (signed_char_type_node, sym->as->rank);
+
+ /* If cfi->data != NULL. */
+ stmtblock_t block2;
+ gfc_init_block (&block2);
+
+ /* gfc->dspan = ((cfi->dim[0].sm % cfi->elem_len)
+ ? cfi->dim[0].sm : cfi->elem_len). */
+ tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
+ tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+ gfc_array_index_type, tmp,
+ fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi)));
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, gfc_index_zero_node);
+ tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
+ gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]),
+ fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi)));
+ gfc_conv_descriptor_span_set (&block2, gfc_desc, tmp);
+
+ /* Calculate offset + set lbound, ubound and stride. */
+ gfc_conv_descriptor_offset_set (&block2, gfc_desc, gfc_index_zero_node);
+ if (sym->as->rank > 0 && !sym->attr.pointer && !sym->attr.allocatable)
+ for (int i = 0; i < sym->as->rank; ++i)
+ {
+ gfc_se se;
+ gfc_init_se (&se, NULL );
+ if (sym->as->lower[i])
+ {
+ gfc_conv_expr (&se, sym->as->lower[i]);
+ tmp = se.expr;
+ }
+ else
+ tmp = gfc_index_one_node;
+ gfc_add_block_to_block (&block2, &se.pre);
+ gfc_conv_descriptor_lbound_set (&block2, gfc_desc, gfc_rank_cst[i],
+ tmp);
+ gfc_add_block_to_block (&block2, &se.post);
+ }
+
+ /* Loop: for (i = 0; i < rank; ++i). */
+ label_loop = gfc_build_label_decl (NULL_TREE);
+ label_end = gfc_build_label_decl (NULL_TREE);
+ idx = gfc_create_var (TREE_TYPE (rank), "idx");
+ gfc_add_modify (&block2, idx, build_int_cst (TREE_TYPE (idx), 0));
+ TREE_USED (label_loop) = 1;
+ tmp = build1_v (LABEL_EXPR, label_loop);
+ gfc_add_expr_to_block (&block2, tmp);
+ tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, idx, rank);
+ tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_end),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block2, tmp);
+
+ /* Loop body. */
+ /* gfc->dim[i].lbound = ... */
+ if (sym->attr.pointer || sym->attr.allocatable)
+ {
+ tmp = gfc_get_cfi_dim_lbound (cfi, idx);
+ gfc_conv_descriptor_lbound_set (&block2, gfc_desc, idx, tmp);
+ }
+ else if (sym->as->rank < 0)
+ gfc_conv_descriptor_lbound_set (&block2, gfc_desc, idx, gfc_index_one_node);
+
+ /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_lbound_get (gfc_desc, idx),
+ gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ gfc_get_cfi_dim_extent (cfi, idx), tmp);
+ gfc_conv_descriptor_ubound_set (&block2, gfc_desc, idx, tmp);
+
+ /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
+ tmp = gfc_get_cfi_dim_sm (cfi, idx);
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ gfc_array_index_type, tmp,
+ fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi)));
+ gfc_conv_descriptor_stride_set (&block2, gfc_desc, idx, tmp);
+
+ /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_stride_get (gfc_desc, idx),
+ gfc_conv_descriptor_lbound_get (gfc_desc, idx));
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_offset_get (gfc_desc), tmp);
+ gfc_conv_descriptor_offset_set (&block2, gfc_desc, tmp);
+
+ /* End of loop body. */
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, signed_char_type_node, idx,
+ build_int_cst (signed_char_type_node, 1));
+ gfc_add_modify (&block2, idx, tmp);
+ gfc_add_expr_to_block (&block2, build1_v (GOTO_EXPR, label_loop));
+ TREE_USED (label_end) = 1;
+ tmp = build1_v (LABEL_EXPR, label_end);
+ gfc_add_expr_to_block (&block2, tmp);
+
+ if (sym->attr.allocatable || sym->attr.pointer)
+ {
+ tmp = gfc_get_cfi_desc_base_addr (cfi),
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, null_pointer_node);
+ tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ gfc_add_block_to_block (&block, &block2);
+
+done:
+ /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */
+ if (sym->attr.optional)
+ {
+ tree present = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, cfi_desc,
+ null_pointer_node);
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ sym->backend_decl,
+ fold_convert (TREE_TYPE (sym->backend_decl),
+ null_pointer_node));
+ tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block), tmp);
+ gfc_add_expr_to_block (init, tmp);
+ }
+ else
+ gfc_add_block_to_block (init, &block);
+
+ /* Nothing to do if either not referenced or pointer not changed. */
+ if (!sym->attr.referenced
+ || ((!sym->attr.pointer && !sym->attr.allocatable)
+ || sym->attr.intent == INTENT_IN))
+ return;
+
+ /* Update pointer + array data data on exit. */
+ gfc_init_block (&block);
+ tmp = gfc_get_cfi_desc_base_addr (cfi);
+ tmp2 = (!sym->attr.dimension
+ ? gfc_desc : gfc_conv_descriptor_data_get (gfc_desc));
+ gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
+
+ /* Set string length for len=:, only. */
+ if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length)
+ {
+ tmp = sym->ts.u.cl->backend_decl;
+ if (sym->ts.kind != 1)
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ sym->ts.u.cl->backend_decl, tmp);
+ tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+ gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+ }
+
+ if (!sym->attr.dimension)
+ goto done_finally;
+
+ gfc_init_block (&block2);
+
+ /* Loop: for (i = 0; i < rank; ++i). */
+ label_loop = gfc_build_label_decl (NULL_TREE);
+ label_end = gfc_build_label_decl (NULL_TREE);
+ idx = gfc_create_var (TREE_TYPE (rank), "idx");
+ gfc_add_modify (&block2, idx, build_int_cst (TREE_TYPE (idx), 0));
+ TREE_USED (label_loop) = 1;
+ tmp = build1_v (LABEL_EXPR, label_loop);
+ gfc_add_expr_to_block (&block2, tmp);
+ tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, idx, rank);
+ tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_end),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block2, tmp);
+
+ /* Loop body. */
+ /* cfi->dim[i].lower_bound = gfc->dim[i].lbound */
+ gfc_add_modify (&block2, gfc_get_cfi_dim_lbound (cfi, idx),
+ gfc_conv_descriptor_lbound_get (gfc_desc, idx));
+ /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound_get (gfc_desc, idx),
+ gfc_conv_descriptor_lbound_get (gfc_desc, idx));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, tmp,
+ gfc_index_one_node);
+ gfc_add_modify (&block2, gfc_get_cfi_dim_extent (cfi, idx), tmp);
+ /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_stride_get (gfc_desc, idx),
+ gfc_conv_descriptor_span_get (gfc_desc));
+ gfc_add_modify (&block2, gfc_get_cfi_dim_sm (cfi, idx), tmp);
+
+ /* End of loop body. */
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, signed_char_type_node, idx,
+ build_int_cst (signed_char_type_node, 1));
+ gfc_add_modify (&block2, idx, tmp);
+ gfc_add_expr_to_block (&block2, build1_v (GOTO_EXPR, label_loop));
+ TREE_USED (label_end) = 1;
+ tmp = build1_v (LABEL_EXPR, label_end);
+ gfc_add_expr_to_block (&block2, tmp);
+
+ /* if (gfc->data != NULL) { block2 }. */
+ tmp = gfc_get_cfi_desc_base_addr (cfi),
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, null_pointer_node);
+ tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+
+done_finally:
+ /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */
+ if (sym->attr.optional)
+ {
+ tree present = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, cfi_desc,
+ null_pointer_node);
+ tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (finally, tmp);
+ }
+ else
+ gfc_add_block_to_block (finally, &block);
+}
/* Generate code for a function. */
@@ -6824,6 +7101,7 @@ gfc_generate_function_code (gfc_namespace * ns)
trans_function_start (sym);
gfc_init_block (&init);
+ gfc_init_block (&cleanup);
if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
{
@@ -6847,6 +7125,76 @@ gfc_generate_function_code (gfc_namespace * ns)
|| ns->parent == NULL)
parent_fake_result_decl = NULL_TREE;
+ /* For BIND(C):
+ - deallocate intent-out allocatable dummy arguments.
+ - Create GFC variable which will later be populated by convert_CFI_desc */
+ if (sym->attr.is_bind_c)
+ for (gfc_formal_arglist *formal = gfc_sym_get_dummy_args (sym);
+ formal; formal = formal->next)
+ {
+ gfc_symbol *fsym = formal->sym;
+ if (!is_CFI_desc (fsym, NULL))
+ continue;
+ if (!fsym->attr.referenced)
+ {
+ gfc_conv_cfi_to_gfc (&init, &cleanup, fsym->backend_decl,
+ NULL_TREE, fsym);
+ continue;
+ }
+
+// FIXME: CHECK THAT OPTIONAL IS HANDLED CORRECTLY IN trans-openmp.c
+// OR OTHERPLACES WITH USE LANG SPECIFIC AND/OR PARAM_DECL IN THE CHECK
+
+// FIXME: TESTING SHOWS THAT DEBUGGING DOES NOT WORK WELL
+// IMPROVE DEBUGGING EXPERIENCE!
+
+ /* Let's now create a local GFI descriptor. Afterwards:
+ desc is the local descriptor,
+ desc_p is a pointer to it
+ and stored in sym->backend_decl
+ GFC_DECL_SAVED_DESCRIPTOR (desc_p) contains the CFI descriptor
+ -> PARM_DECL and before sym->backend_decl.
+ For scalars, decl == decl_p is a pointer variable. */
+ tree desc_p, desc;
+ location_t loc = gfc_get_location (&sym->declared_at);
+ if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length)
+ fsym->ts.u.cl->backend_decl = gfc_create_var (gfc_array_index_type,
+ fsym->name);
+ else if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->backend_decl)
+ {
+ gfc_se se;
+ gfc_init_se (&se, NULL );
+ gfc_conv_expr (&se, fsym->ts.u.cl->length);
+ gfc_add_block_to_block (&init, &se.pre);
+ fsym->ts.u.cl->backend_decl = se.expr;
+ gcc_assert(se.post.head == NULL_TREE);
+ }
+ /* Nullify, otherwise gfc_sym_type will return the CFI type. */
+ tree tmp = fsym->backend_decl;
+ fsym->backend_decl = NULL;
+ tree type = gfc_sym_type (fsym);
+ gcc_assert (POINTER_TYPE_P (type));
+ if (POINTER_TYPE_P (TREE_TYPE (type)))
+ /* For instance, allocatable scalars. */
+ type = TREE_TYPE (type);
+ if (TREE_CODE (type) == REFERENCE_TYPE)
+ /* FIXME: restrict qualifier? */
+ type = build_pointer_type (TREE_TYPE (type));
+ desc_p = build_decl (loc, VAR_DECL, get_identifier (fsym->name), type);
+ if (!fsym->attr.dimension)
+ desc = desc_p;
+ else
+ {
+ desc = gfc_create_var (TREE_TYPE (type), fsym->name);
+ gfc_add_modify (&init, desc_p, gfc_build_addr_expr (NULL, desc));
+ }
+ //gfc_allocate_lang_decl (desc_p);
+ //GFC_DECL_SAVED_DESCRIPTOR (desc_p) = tmp;
+ pushdecl (desc_p);
+ fsym->backend_decl = desc_p;
+ gfc_conv_cfi_to_gfc (&init, &cleanup, tmp, desc, fsym);
+ }
+
gfc_generate_contained_functions (ns);
has_coarray_vars = false;
@@ -7002,8 +7350,6 @@ gfc_generate_function_code (gfc_namespace * ns)
gfc_add_expr_to_block (&body, gfc_generate_return ());
}
- gfc_init_block (&cleanup);
-
/* Reset recursion-check variable. */
if (recurcheckvar != NULL_TREE)
{
@@ -2864,6 +2864,9 @@ tree
gfc_maybe_dereference_var (gfc_symbol *sym, tree var, bool descriptor_only_p,
bool is_classarray)
{
+ if (is_CFI_desc (sym, NULL))
+ return build_fold_indirect_ref_loc (input_location, var);
+
/* Characters are entirely different from other types, they are treated
separately. */
if (sym->ts.type == BT_CHARACTER)
@@ -5481,168 +5484,452 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
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;
- tree cond;
- tree desc_attr;
- int attribute;
- int cfi_attribute;
- symbol_attribute attr = gfc_expr_attr (e);
+ stmtblock_t block, block2;
+ tree cfi, gfc, gfc_strlen, tmp, tmp2;
+ tree present = NULL;
+ tree rank;
+ gfc_se se;
+
+ if (fsym->attr.optional
+ && e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional)
+ present = gfc_conv_expr_present (e->symtree->n.sym);
- /* 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))
+ // FIXME: If already a CFI descriptor, use it - unless bounds have to be modified.
+ // In particular, re-use type - especially for AT_ASSUMED
+
+ gfc_init_block (&block);
+
+ /* Convert original argument to a tree. */
+ gfc_init_se (&se, NULL);
+ if (e->rank == 0)
{
- if (attr.pointer)
- attribute = 0;
- else if (attr.allocatable)
- attribute = 1;
+ gfc_conv_expr (&se, e);
+ gfc = se.expr;
+ if (!POINTER_TYPE_P (TREE_TYPE (gfc)))
+ gfc = gfc_build_addr_expr (NULL_TREE, gfc);
}
-
- if (fsym->attr.pointer)
- cfi_attribute = 0;
- else if (fsym->attr.allocatable)
- cfi_attribute = 1;
else
- cfi_attribute = 2;
-
- if (e->rank != 0)
{
- parmse->force_no_tmp = 1;
+ se.force_no_tmp = 1;
if (fsym->attr.contiguous
&& !gfc_is_simply_contiguous (e, false, true))
- gfc_conv_subref_array_arg (parmse, e, false, fsym->attr.intent,
+ gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
fsym->attr.pointer);
else
- gfc_conv_expr_descriptor (parmse, e);
-
- if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
- parmse->expr = build_fold_indirect_ref_loc (input_location,
- parmse->expr);
- bool is_artificial = (INDIRECT_REF_P (parmse->expr)
- ? DECL_ARTIFICIAL (TREE_OPERAND (parmse->expr, 0))
- : DECL_ARTIFICIAL (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
- && (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)
- and the dtype updated. Assumed type entities are only allowed
- to be dummies in Fortran. They therefore lack the decl specific
- appendiges and so must be treated differently from other fortran
- entities passed to CFI descriptors in the interface decl. */
- type = e->ts.type != BT_ASSUMED ? gfc_typenode_for_spec (&e->ts) :
- NULL_TREE;
-
- if (type && is_artificial
- && 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 (type == NULL_TREE
- || (!is_subref_array (e) && !is_artificial))
- {
- /* Make sure that the span is set for expressions where it
- might not have been done already. */
- tmp = gfc_conv_descriptor_elem_len (parmse->expr);
- tmp = fold_convert (gfc_array_index_type, tmp);
- gfc_conv_descriptor_span_set (&parmse->pre, parmse->expr, tmp);
- }
+ gfc_conv_expr_descriptor (&se, e);
+ gfc = se.expr;
+ /* For dt(:)%var the elem_len*stride != sm, hence, GFC uses
+ elem_len = sizeof(dt) and base_addr = dt(lb) instead.
+ gfc_get_dataptr_offset fixes the base_addr; for elem_len, see below.
+ While sm is fine as it uses span*stride and not elem_len. */
+ if (POINTER_TYPE_P (TREE_TYPE (gfc)))
+ gfc = build_fold_indirect_ref_loc (input_location, gfc);
+ else if (is_subref_array (e) && e->ts.type != BT_CHARACTER)
+ gfc_get_dataptr_offset (&se.pre, gfc, gfc, NULL, true, e);
+ }
+ gfc_strlen = se.string_length;
+ gfc_add_block_to_block (&block, &se.pre);
+
+ /* Create array decriptor and set version, rank, attribute, type. */
+ cfi = gfc_create_var (gfc_get_cfi_type (e->rank < 0
+ ? GFC_MAX_DIMENSIONS : e->rank,
+ false), "cfi");
+ tmp = gfc_get_cfi_desc_version (cfi);
+ gfc_add_modify (&block, tmp,
+ build_int_cst (TREE_TYPE (tmp), CFI_VERSION));
+ if (e->rank < 0)
+ rank = fold_convert (signed_char_type_node, gfc_conv_descriptor_rank (gfc));
+ else
+ rank = build_int_cst (signed_char_type_node, e->rank);
+ tmp = gfc_get_cfi_desc_rank (cfi);
+ gfc_add_modify (&block, tmp, rank);
+ int itype = CFI_type_other;
+ if (e->ts.f90_type == BT_VOID)
+ itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
+ ? CFI_type_cfunptr : CFI_type_cptr);
+ else
+ switch (e->ts.type)
+ {
+ case BT_INTEGER:
+ case BT_LOGICAL:
+ case BT_REAL:
+ case BT_COMPLEX:
+ case BT_CHARACTER:
+ itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
+ break;
+ case BT_DERIVED:
+ itype = CFI_type_struct;
+ break;
+ case BT_VOID:
+ itype = (e->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR
+ ? CFI_type_cfunptr : CFI_type_cptr);
+ break;
+ case BT_ASSUMED:
+ itype = CFI_type_other; // FIXME: Or CFI_type_cptr ?
+ break;
+ case BT_CLASS:
+ case BT_PROCEDURE:
+ case BT_HOLLERITH:
+ case BT_UNION:
+ case BT_BOZ:
+ case BT_UNKNOWN:
+ // FIXME: Really unreachable? Or reachable for type(*) ? If so, CFI_type_other?
+ gcc_unreachable ();
+ }
+
+ tmp = gfc_get_cfi_desc_type (cfi);
+ gfc_add_modify (&block, tmp,
+ build_int_cst (TREE_TYPE (tmp), itype));
+
+ int attr = CFI_attribute_other;
+ if (fsym->attr.pointer)
+ attr = CFI_attribute_pointer;
+ else if (fsym->attr.allocatable)
+ attr = CFI_attribute_allocatable;
+ tmp = gfc_get_cfi_desc_attribute (cfi);
+ gfc_add_modify (&block, tmp,
+ build_int_cst (TREE_TYPE (tmp), attr));
+
+ if (e->rank == 0)
+ {
+ tmp = gfc_get_cfi_desc_base_addr (cfi);
+ gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), gfc));
}
else
{
- gfc_conv_expr (parmse, e);
-
- if (POINTER_TYPE_P (TREE_TYPE (parmse->expr)))
- parmse->expr = build_fold_indirect_ref_loc (input_location,
- parmse->expr);
+ tmp = gfc_get_cfi_desc_base_addr (cfi);
+ tmp2 = gfc_conv_descriptor_data_get (gfc);
+ gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
+ }
- parmse->expr = gfc_conv_scalar_to_descriptor (parmse,
- parmse->expr, attr);
+ /* When allocatable + intent out, free the cfi descriptor. */
+ if (fsym->attr.allocatable && fsym->attr.intent == INTENT_OUT)
+ {
+ tmp = gfc_get_cfi_desc_base_addr (cfi);
+ tree call = builtin_decl_explicit (BUILT_IN_FREE);
+ call = build_call_expr_loc (input_location, call, 1, tmp);
+ gfc_add_expr_to_block (&block, fold_convert (void_type_node, call));
+ gfc_add_modify (&block, tmp,
+ fold_convert (TREE_TYPE (tmp), null_pointer_node));
+ goto done;
}
- /* Set the CFI attribute field through a temporary value for the
- gfc attribute. */
- desc_attr = gfc_conv_descriptor_attribute (parmse->expr);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- void_type_node, desc_attr,
- build_int_cst (TREE_TYPE (desc_attr), cfi_attribute));
- gfc_add_expr_to_block (&parmse->pre, tmp);
+ /* If not unallocated/unassociated. */
+ gfc_init_block (&block2);
- /* Now pass the gfc_descriptor by reference. */
- parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+ if (e->ts.type == BT_CHARACTER)
+ {
+ gcc_assert (gfc_strlen);
+ tmp = gfc_strlen;
+ if (e->ts.kind != 1)
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_charlen_type_node, tmp,
+ build_int_cst (gfc_charlen_type_node,
+ e->ts.kind));
+ tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+ gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+ }
+ else if (e->ts.type != BT_ASSUMED)
+ {
+ /* Length is known at compile time; use use 'block' for it. */
+ tmp = size_in_bytes (gfc_typenode_for_spec (&e->ts));
+ tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+ gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+ }
+ else
+ {
+ tmp = gfc_conv_descriptor_elem_len (gfc);
+ tmp2 = gfc_get_cfi_desc_elem_len (cfi);
+ gfc_add_modify (&block2, tmp2, fold_convert (TREE_TYPE (tmp2), tmp));
+ }
- /* Variables to point to the gfc and CFI descriptors; cfi = NULL implies
- that the CFI descriptor is allocated by the gfor_fndecl_gfc_to_cfi call. */
- gfc_desc_ptr = parmse->expr;
- cfi_desc_ptr = gfc_create_var (pvoid_type_node, "cfi");
- gfc_add_modify (&parmse->pre, cfi_desc_ptr, null_pointer_node);
+ if (e->ts.type == BT_ASSUMED)
+ {
+ /* Note: type(*) implies assumed-shape/assumed-rank if fsym requires
+ an CFI descriptor. Use the type in the descritor as it provide
+ mode information. (Quality of implementation feature.) */
+ tree cond;
+ tree ctype = gfc_get_cfi_desc_type (cfi);
+ tree type = fold_convert (TREE_TYPE (ctype),
+ gfc_conv_descriptor_type (gfc));
+ tree kind = fold_convert (TREE_TYPE (ctype),
+ gfc_conv_descriptor_elem_len (gfc));
+ kind = fold_build2_loc (input_location, LSHIFT_EXPR, TREE_TYPE (type),
+ kind, build_int_cst (TREE_TYPE (type),
+ CFI_type_kind_shift));
+
+ /* if (BT_VOID) CFI_type_cptr else CFI_type_other */
+ /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+ build_int_cst (TREE_TYPE (type), BT_VOID));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
+ build_int_cst (TREE_TYPE (type), CFI_type_cptr));
+ tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ ctype,
+ build_int_cst (TREE_TYPE (type), CFI_type_other));
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+ /* if (BT_DERIVED) CFI_type_struct else < tmp2 > */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+ build_int_cst (TREE_TYPE (type), BT_DERIVED));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, ctype,
+ build_int_cst (TREE_TYPE (type), CFI_type_struct));
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+ /* if (BT_CHARACTER) CFI_type_struct + kind=1 else < tmp2 > */
+ /* Note: could also be kind=4, with cfi->elem_len = gfc->elem_len/4. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+ build_int_cst (TREE_TYPE (type), BT_CHARACTER));
+ tmp = build_int_cst (TREE_TYPE (type),
+ CFI_type_from_type_kind (CFI_type_Character, 1));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ ctype, tmp);
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+ /* if (BT_COMPLEX) CFI_type_Character + kind/2 else < tmp2 > */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+ build_int_cst (TREE_TYPE (type), BT_CHARACTER));
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (type),
+ kind, build_int_cst (TREE_TYPE (type), 2));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type), tmp,
+ build_int_cst (TREE_TYPE (type),
+ CFI_type_Complex));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ ctype, tmp);
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+ /* if (BT_INTEGER || BT_LOGICAL || BT_REAL) type + kind else <tmp2> */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+ build_int_cst (TREE_TYPE (type), BT_INTEGER));
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+ build_int_cst (TREE_TYPE (type), BT_LOGICAL));
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+ cond, tmp);
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+ build_int_cst (TREE_TYPE (type), BT_REAL));
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+ cond, tmp);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (type),
+ type, kind);
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ ctype, tmp);
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+ gfc_add_expr_to_block (&block2, tmp2);
+ }
- /* Allocate the CFI descriptor itself 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);
+ if (e->rank != 0)
+ {
+ /* Loop: for (i = 0; i < rank; ++i). */
+ tree label_loop = gfc_build_label_decl (NULL_TREE);
+ tree label_end = gfc_build_label_decl (NULL_TREE);
+ tree idx = gfc_create_var (signed_char_type_node, "idx");
+ gfc_add_modify (&block2, idx, build_int_cst (TREE_TYPE (idx), 0));
+ TREE_USED (label_loop) = 1;
+ tmp = build1_v (LABEL_EXPR, label_loop);
+ gfc_add_expr_to_block (&block2, tmp);
+ tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, idx,
+ rank);
+ tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_end),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block2, tmp);
- /* Now set the gfc descriptor attribute. */
- tmp = fold_build2_loc (input_location, MODIFY_EXPR,
- void_type_node, desc_attr,
- build_int_cst (TREE_TYPE (desc_attr), attribute));
- gfc_add_expr_to_block (&parmse->pre, tmp);
+ /* Loop body. */
+ /* cfi->dim[i].lower_bound = (allocatable/pointer)
+ ? gfc->dim[i].lbound : 0 */
+ if (fsym->attr.pointer || fsym->attr.allocatable)
+ tmp = gfc_conv_descriptor_lbound_get (gfc, idx);
+ else
+ tmp = gfc_index_zero_node;
+ gfc_add_modify (&block2, gfc_get_cfi_dim_lbound (cfi, idx), tmp);
+ /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound_get (gfc, idx),
+ gfc_conv_descriptor_lbound_get (gfc, idx));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ gfc_add_modify (&block2, gfc_get_cfi_dim_extent (cfi, idx), tmp);
+ /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_stride_get (gfc, idx),
+ gfc_conv_descriptor_span_get (gfc));
+ gfc_add_modify (&block2, gfc_get_cfi_dim_sm (cfi, idx), tmp);
+
+ /* End of loop body. */
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, signed_char_type_node,
+ idx, build_int_cst (signed_char_type_node, 1));
+ gfc_add_modify (&block2, idx, tmp);
+ gfc_add_expr_to_block (&block2, build1_v (GOTO_EXPR, label_loop));
+ TREE_USED (label_end) = 1;
+ tmp = build1_v (LABEL_EXPR, label_end);
+ gfc_add_expr_to_block (&block2, tmp);
- /* The CFI descriptor is passed to the bind_C procedure. */
- parmse->expr = cfi_desc_ptr;
+ if (e->expr_type == EXPR_VARIABLE
+ && e->ref
+ && e->ref->u.ar.type == AR_FULL
+ && e->symtree->n.sym->attr.dummy
+ && e->symtree->n.sym->as
+ && e->symtree->n.sym->as->type == AS_ASSUMED_SIZE)
+ {
+ tmp = gfc_get_cfi_dim_extent (cfi, gfc_rank_cst[e->rank-1]),
+ gfc_add_modify (&block2, tmp, build_int_cst (TREE_TYPE (tmp), -1));
+ }
+ }
- /* Free the CFI descriptor. */
- tmp = gfc_call_free (cfi_desc_ptr);
- gfc_prepend_expr_to_block (&parmse->post, tmp);
+// FIXME: Check that the bounds calculation is proper - for all kind of vars, including strided input etc.
- /* Transfer values back to gfc descriptor. */
- if (cfi_attribute != 2 /* CFI_attribute_other. */
- && !fsym->attr.value
- && fsym->attr.intent != INTENT_IN)
+ if (fsym->attr.allocatable || fsym->attr.pointer)
{
- 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);
+ tmp = gfc_get_cfi_desc_base_addr (cfi),
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, null_pointer_node);
+ tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
}
+ else
+ gfc_add_block_to_block (&block, &block2);
- /* Deal with an optional dummy being passed to an optional formal arg
- by finishing the pre and post blocks and making their execution
- conditional on the dummy being present. */
- if (fsym->attr.optional && e->expr_type == EXPR_VARIABLE
- && e->symtree->n.sym->attr.optional)
+
+done:
+ parmse->expr = gfc_build_addr_expr (NULL_TREE, cfi);
+ if (present)
{
- cond = gfc_conv_expr_present (e->symtree->n.sym);
- tmp = fold_build2 (MODIFY_EXPR, void_type_node,
- cfi_desc_ptr,
- build_int_cst (pvoid_type_node, 0));
- tmp = build3_v (COND_EXPR, cond,
- gfc_finish_block (&parmse->pre), tmp);
+ parmse->expr = build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (parmse->expr),
+ present, parmse->expr, null_pointer_node);
+ tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&parmse->pre, tmp);
- tmp = build3_v (COND_EXPR, cond,
- gfc_finish_block (&parmse->post),
+ }
+ else
+ gfc_add_block_to_block (&parmse->pre, &block);
+
+ gfc_init_block (&block);
+
+ if ((!fsym->attr.allocatable && !fsym->attr.pointer)
+ || fsym->attr.intent == INTENT_IN)
+ goto post_call;
+
+ gfc_init_block (&block2);
+ if (e->rank == 0)
+ {
+ tmp = gfc_get_cfi_desc_base_addr (cfi);
+ gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
+ }
+ else
+ {
+ tmp = gfc_get_cfi_desc_base_addr (cfi);
+ gfc_conv_descriptor_data_set (&block, gfc, tmp);
+
+ /* gfc->dspan = ((cfi->dim[0].sm % cfi->elem_len)
+ ? cfi->dim[0].sm : cfi->elem_len). */
+ tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
+ tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+ gfc_array_index_type, tmp,
+ fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi)));
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, gfc_index_zero_node);
+ tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
+ gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]),
+ fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi)));
+ gfc_conv_descriptor_span_set (&block2, gfc, tmp);
+
+ /* Calculate offset + set lbound, ubound and stride. */
+ gfc_conv_descriptor_offset_set (&block2, gfc, gfc_index_zero_node);
+ /* Loop: for (i = 0; i < rank; ++i). */
+ tree label_loop = gfc_build_label_decl (NULL_TREE);
+ tree label_end = gfc_build_label_decl (NULL_TREE);
+ tree idx = gfc_create_var (signed_char_type_node, "idx");
+ gfc_add_modify (&block2, idx, build_int_cst (TREE_TYPE (idx), 0));
+ TREE_USED (label_loop) = 1;
+ tmp = build1_v (LABEL_EXPR, label_loop);
+ gfc_add_expr_to_block (&block2, tmp);
+ tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, idx,
+ rank);
+ tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_end),
build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block2, tmp);
+
+ /* Loop body. */
+
+// FIXME: CHECK!
+ /* gfc->dim[i].lbound = ... */
+ tmp = gfc_get_cfi_dim_lbound (cfi, idx);
+ gfc_conv_descriptor_lbound_set (&block2, gfc, idx, tmp);
+
+ /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_lbound_get (gfc, idx),
+ gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ gfc_get_cfi_dim_extent (cfi, idx), tmp);
+ gfc_conv_descriptor_ubound_set (&block2, gfc, idx, tmp);
+
+ /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
+ tmp = gfc_get_cfi_dim_sm (cfi, idx);
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ gfc_array_index_type, tmp,
+ fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi)));
+ gfc_conv_descriptor_stride_set (&block2, gfc, idx, tmp);
+
+ /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_stride_get (gfc, idx),
+ gfc_conv_descriptor_lbound_get (gfc, idx));
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_offset_get (gfc), tmp);
+ gfc_conv_descriptor_offset_set (&block2, gfc, tmp);
+
+ /* End of loop body. */
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, signed_char_type_node,
+ idx, build_int_cst (signed_char_type_node, 1));
+ gfc_add_modify (&block2, idx, tmp);
+ gfc_add_expr_to_block (&block2, build1_v (GOTO_EXPR, label_loop));
+ TREE_USED (label_end) = 1;
+ tmp = build1_v (LABEL_EXPR, label_end);
+ gfc_add_expr_to_block (&block2, tmp);
+ }
+
+ if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
+ {
+ tmp = fold_convert (gfc_charlen_type_node,
+ gfc_get_cfi_desc_elem_len (cfi));
+ if (e->ts.kind != 1)
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ gfc_charlen_type_node, tmp,
+ build_int_cst (gfc_charlen_type_node,
+ e->ts.kind));
+ gfc_add_modify (&block2, gfc_strlen, tmp);
+ }
+
+ tmp = gfc_get_cfi_desc_base_addr (cfi),
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, null_pointer_node);
+ tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+
+post_call:
+ gfc_add_block_to_block (&block, &se.post);
+ if (present && block.head)
+ {
+ tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block),
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&parmse->post, tmp);
}
+ else if (block.head)
+ gfc_add_block_to_block (&parmse->post, &block);
+
+
+// Update pointer
+// If char -> update length
+// (e->ts.type != BT_CHARACTER || !e->ts.u.cl->length)))*
+// If array, update descriptor etc. -> else = done.
}
@@ -5761,17 +6048,12 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
arg = arg->next, formal = formal ? formal->next : NULL, ++argc)
{
bool finalized = false;
- bool assumed_length_string = false;
tree derived_array = NULL_TREE;
e = arg->expr;
fsym = formal ? formal->sym : NULL;
parm_kind = MISSING;
- if (fsym && fsym->ts.type == BT_CHARACTER
- && (!fsym->ts.u.cl || !fsym->ts.u.cl->length))
- assumed_length_string = true;
-
/* If the procedure requires an explicit interface, the actual
argument is passed according to the corresponding formal
argument. If the corresponding formal argument is a POINTER,
@@ -6002,9 +6284,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
parmse.expr = convert (type, tmp);
}
- else if (sym->attr.is_bind_c && e
- && (is_CFI_desc (fsym, NULL)
- || assumed_length_string))
+ else if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
/* Implement F2018, 18.3.6, list item (5), bullet point 2. */
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
@@ -6214,7 +6494,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
if (fsym && fsym->attr.intent == INTENT_OUT
&& (fsym->attr.allocatable
|| (fsym->ts.type == BT_CLASS
- && CLASS_DATA (fsym)->attr.allocatable)))
+ && CLASS_DATA (fsym)->attr.allocatable))
+ && !is_CFI_desc (fsym, NULL))
{
stmtblock_t block;
tree ptr;
@@ -6448,8 +6729,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
parmse.force_tmp = 1;
}
- if (sym->attr.is_bind_c && e
- && (is_CFI_desc (fsym, NULL) || assumed_length_string))
+ if (sym->attr.is_bind_c && e && is_CFI_desc (fsym, NULL))
/* Implement F2018, 18.3.6, list item (5), bullet point 2. */
gfc_conv_gfc_desc_to_cfi_desc (&parmse, e, fsym);
@@ -6536,9 +6816,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
}
/* If an ALLOCATABLE dummy argument has INTENT(OUT) and is
- allocated on entry, it must be deallocated. */
+ allocated on entry, it must be deallocated.
+ CFI descriptors are handled elsewhere. */
if (fsym && fsym->attr.allocatable
- && fsym->attr.intent == INTENT_OUT)
+ && fsym->attr.intent == INTENT_OUT
+ && !is_CFI_desc (fsym, NULL))
{
if (fsym->ts.type == BT_DERIVED
&& fsym->ts.u.derived->attr.alloc_comp)
@@ -3669,10 +3669,7 @@ gfc_trans_select_rank_cases (gfc_code * code)
tree tmp;
tree cond;
tree low;
- tree sexpr;
tree rank;
- tree rank_minus_one;
- tree minus_one;
gfc_se se;
gfc_se cse;
stmtblock_t block;
@@ -3686,24 +3683,25 @@ gfc_trans_select_rank_cases (gfc_code * code)
gfc_conv_expr_descriptor (&se, code->expr1);
rank = gfc_conv_descriptor_rank (se.expr);
rank = gfc_evaluate_now (rank, &block);
- minus_one = build_int_cst (TREE_TYPE (rank), -1);
- tmp = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type,
- fold_convert (gfc_array_index_type, rank),
- build_int_cst (gfc_array_index_type, 1));
- rank_minus_one = gfc_evaluate_now (tmp, &block);
- tmp = gfc_conv_descriptor_ubound_get (se.expr, rank_minus_one);
- cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
- tmp, build_int_cst (TREE_TYPE (tmp), -1));
- tmp = fold_build3_loc (input_location, COND_EXPR,
- TREE_TYPE (rank), cond,
- rank, minus_one);
- cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
- rank, build_int_cst (TREE_TYPE (rank), 0));
- sexpr = fold_build3_loc (input_location, COND_EXPR,
- TREE_TYPE (rank), cond,
- rank, tmp);
- sexpr = gfc_evaluate_now (sexpr, &block);
+ symbol_attribute attr = gfc_expr_attr (code->expr1);
+ if (!attr.pointer || !attr.allocatable)
+ {
+ /* Special case for assumed-rank ('rank(*)', internally -1):
+ rank = (rank == 0 || ubound[rank-1] != -1) ? rank : -1. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
+ rank, build_int_cst (TREE_TYPE (rank), 0));
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ fold_convert (gfc_array_index_type, rank),
+ gfc_index_one_node);
+ tmp = gfc_conv_descriptor_ubound_get (se.expr, tmp);
+ tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ tmp, build_int_cst (TREE_TYPE (tmp), -1));
+ cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ logical_type_node, cond, tmp);
+ tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (rank),
+ cond, rank, build_int_cst (TREE_TYPE (rank), -1));
+ rank = gfc_evaluate_now (tmp, &block);
+ }
TREE_USED (code->exit_label) = 0;
repeat:
@@ -3747,8 +3745,8 @@ repeat:
if (low != NULL_TREE)
{
cond = fold_build2_loc (input_location, EQ_EXPR,
- TREE_TYPE (sexpr), sexpr,
- fold_convert (TREE_TYPE (sexpr), low));
+ TREE_TYPE (rank), rank,
+ fold_convert (TREE_TYPE (rank), low));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
cond, tmp,
build_empty_stmt (input_location));
@@ -77,6 +77,7 @@ static GTY(()) tree gfc_desc_dim_type;
static GTY(()) tree gfc_max_array_element_size;
static GTY(()) tree gfc_array_descriptor_base[2 * (GFC_MAX_DIMENSIONS+1)];
static GTY(()) tree gfc_array_descriptor_base_caf[2 * (GFC_MAX_DIMENSIONS+1)];
+static GTY(()) tree gfc_cfi_descriptor_base[2 * (CFI_MAX_RANK + 2)];
/* Arrays for all integral and real kinds. We'll fill this in at runtime
after the target has a chance to process command-line options. */
@@ -1575,8 +1576,9 @@ gfc_get_dtype_rank_type (int rank, tree etype)
field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
GFC_DTYPE_RANK);
- CONSTRUCTOR_APPEND_ELT (v, field,
- build_int_cst (TREE_TYPE (field), rank));
+ if (rank >= 0)
+ CONSTRUCTOR_APPEND_ELT (v, field,
+ build_int_cst (TREE_TYPE (field), rank));
field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node),
GFC_DTYPE_TYPE);
@@ -2244,7 +2246,7 @@ gfc_nonrestricted_type (tree t)
especially for character and array types. */
tree
-gfc_sym_type (gfc_symbol * sym)
+gfc_sym_type (gfc_symbol * sym, bool is_bind_c)
{
tree type;
int byref;
@@ -2299,7 +2301,11 @@ gfc_sym_type (gfc_symbol * sym)
if (!restricted)
type = gfc_nonrestricted_type (type);
- if (sym->attr.dimension || sym->attr.codimension)
+ /* Dummy argument to a bind(C) procedure. */
+ if (is_bind_c && is_CFI_desc (sym, NULL))
+ type = gfc_get_cfi_type (sym->attr.dimension ? sym->as->rank : 0,
+ restricted);
+ else if (sym->attr.dimension || sym->attr.codimension)
{
if (gfc_is_nodesc_array (sym))
{
@@ -3131,7 +3137,7 @@ gfc_get_function_type (gfc_symbol * sym, gfc_actual_arglist *actual_args,
type = build_pointer_type (type);
}
else
- type = gfc_sym_type (arg);
+ type = gfc_sym_type (arg, sym->attr.is_bind_c);
/* Parameter Passing Convention
@@ -3722,4 +3728,93 @@ gfc_get_caf_reference_type ()
return reference_type;
}
+static tree
+gfc_get_cfi_dim_type ()
+{
+ static tree CFI_dim_t = NULL;
+
+ if (CFI_dim_t)
+ return CFI_dim_t;
+
+ CFI_dim_t = make_node (RECORD_TYPE);
+ TYPE_NAME (CFI_dim_t) = get_identifier ("CFI_dim_t");
+ TYPE_NAMELESS (CFI_dim_t) = 1;
+ tree field;
+ tree *chain = NULL;
+ field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("lower_bound"),
+ gfc_array_index_type, &chain);
+ suppress_warning (field);
+ field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("extent"),
+ gfc_array_index_type, &chain);
+ suppress_warning (field);
+ field = gfc_add_field_to_struct_1 (CFI_dim_t, get_identifier ("sm"),
+ gfc_array_index_type, &chain);
+ suppress_warning (field);
+ gfc_finish_type (CFI_dim_t);
+ TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (CFI_dim_t)) = 1;
+ return CFI_dim_t;
+}
+
+
+/* Return the CFI type; use dimen == -1 for dim[] (only for pointers);
+ otherwise dim[dimen] is used. */
+
+tree
+gfc_get_cfi_type (int dimen, bool restricted)
+{
+ gcc_assert (dimen >= -1 && dimen <= CFI_MAX_RANK);
+
+ int idx = 2*(dimen + 1) + restricted;
+
+ if (gfc_cfi_descriptor_base[idx])
+ return gfc_cfi_descriptor_base[idx];
+
+ /* Build the type node. */
+ tree CFI_cdesc_t = make_node (RECORD_TYPE);
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ if (dimen != -1)
+ sprintf (name, "CFI_cdesc_t" GFC_RANK_PRINTF_FORMAT, dimen);
+ TYPE_NAME (CFI_cdesc_t) = get_identifier (dimen < 0 ? "CFI_cdesc_t" : name);
+ TYPE_NAMELESS (CFI_cdesc_t) = 1;
+
+ tree field;
+ tree *chain = NULL;
+ field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("base_addr"),
+ (restricted ? prvoid_type_node
+ : ptr_type_node), &chain);
+ suppress_warning (field);
+ field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("elem_len"),
+ size_type_node, &chain);
+ suppress_warning (field);
+ field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("version"),
+ integer_type_node, &chain);
+ suppress_warning (field);
+ field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("rank"),
+ signed_char_type_node, &chain);
+ suppress_warning (field);
+ field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("attribute"),
+ signed_char_type_node, &chain);
+ suppress_warning (field);
+ field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("type"),
+ get_typenode_from_name (INT16_TYPE),
+ &chain);
+ suppress_warning (field);
+
+ if (dimen != 0)
+ {
+ tree range = NULL_TREE;
+ if (dimen > 0)
+ range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+ gfc_rank_cst[dimen - 1]);
+ tree CFI_dim_t = build_array_type (gfc_get_cfi_dim_type (), range);
+ field = gfc_add_field_to_struct_1 (CFI_cdesc_t, get_identifier ("dim"),
+ CFI_dim_t, &chain);
+ suppress_warning (field);
+ }
+
+ gfc_finish_type (CFI_cdesc_t);
+ gfc_cfi_descriptor_base[idx] = CFI_cdesc_t;
+ return CFI_cdesc_t;
+}
+
#include "gt-fortran-trans-types.h"
@@ -84,7 +84,8 @@ tree gfc_get_character_type (int, gfc_charlen *);
tree gfc_get_character_type_len (int, tree);
tree gfc_get_character_type_len_for_eltype (tree, tree);
-tree gfc_sym_type (gfc_symbol *);
+tree gfc_sym_type (gfc_symbol *, bool is_bind_c_arg = false);
+tree gfc_get_cfi_type (int dimen, bool restricted);
tree gfc_typenode_for_spec (gfc_typespec *, int c = 0);
int gfc_copy_dt_decls_ifequal (gfc_symbol *, gfc_symbol *, bool);
@@ -608,9 +608,9 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
if (once)
{
- tmpvar = gfc_create_var (logical_type_node, "print_warning");
+ tmpvar = gfc_create_var (boolean_type_node, "print_warning");
TREE_STATIC (tmpvar) = 1;
- DECL_INITIAL (tmpvar) = logical_true_node;
+ DECL_INITIAL (tmpvar) = boolean_true_node;
gfc_add_expr_to_block (pblock, tmpvar);
}
@@ -631,7 +631,7 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
va_end (ap);
if (once)
- gfc_add_modify (&block, tmpvar, logical_false_node);
+ gfc_add_modify (&block, tmpvar, boolean_false_node);
body = gfc_finish_block (&block);
@@ -643,9 +643,8 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
{
if (once)
cond = fold_build2_loc (gfc_get_location (where), TRUTH_AND_EXPR,
- long_integer_type_node, tmpvar, cond);
- else
- cond = fold_convert (long_integer_type_node, cond);
+ boolean_type_node, tmpvar,
+ fold_convert (boolean_type_node, cond));
tmp = fold_build3_loc (gfc_get_location (where), COND_EXPR, void_type_node,
cond, body,
@@ -855,8 +855,6 @@ extern GTY(()) tree gfor_fndecl_ctime;
extern GTY(()) tree gfor_fndecl_fdate;
extern GTY(()) tree gfor_fndecl_in_pack;
extern GTY(()) tree gfor_fndecl_in_unpack;
-extern GTY(()) tree gfor_fndecl_cfi_to_gfc;
-extern GTY(()) tree gfor_fndecl_gfc_to_cfi;
extern GTY(()) tree gfor_fndecl_associated;
extern GTY(()) tree gfor_fndecl_system_clock4;
extern GTY(()) tree gfor_fndecl_system_clock8;
@@ -19,23 +19,37 @@ contains
subroutine substr(str) BIND(C)
character(*) :: str(:)
- if (str(2) .ne. "ghi") stop 2
+ if (str(1) .ne. "bcd") stop 2
+ if (str(2) .ne. "ghi") stop 3
str = ['uvw','xyz']
end subroutine
+ subroutine substr4(str4) BIND(C)
+ character(*, kind=4) :: str4(:)
+ print *, str4(1)
+ print *, str4(2)
+ if (str4(1) .ne. 4_"bcd") stop 4
+ if (str4(2) .ne. 4_"ghi") stop 5
+ str4 = [4_'uvw', 4_'xyz']
+ end subroutine
+
end module
program p
use mod_ctg
implicit none
real :: x(6)
- character(5) :: str(2) = ['abcde','fghij']
+ character(5) :: str(2) = ['abcde', 'fghij']
+ character(5, kind=4) :: str4(2) = [4_'abcde', 4_'fghij']
integer :: i
x = [ (real(i), i=1, size(x)) ]
call ctg(x(2::2))
if (any (abs (x - [1.,20.,3.,40.,5.,60.]) > 1.e-6)) stop 3
- call substr(str(:)(2:4))
- if (any (str .ne. ['auvwe','fxyzj'])) stop 4
+ !call substr(str(:)(2:4))
+ !if (any (str .ne. ['auvwe','fxyzj'])) stop 4
+
+ call substr4(str4(:)(2:4))
+ if (any (str4 .ne. [4_'auvwe', 4_'fxyzj'])) stop 4
end program
@@ -3,6 +3,8 @@
! Test the fix for PR93963
!
+module m
+contains
function rank_p(this) result(rnk) bind(c)
use, intrinsic :: iso_c_binding, only: c_int
@@ -11,6 +13,13 @@ function rank_p(this) result(rnk) bind(c)
integer(kind=c_int), pointer, intent(in) :: this(..)
integer(kind=c_int) :: rnk
+ if (.not. associated (this)) then
+ rnk = rank (this)
+ return
+ end if
+
+ ! Only valid when associated
+ ! As otherweise, only inquiry functions permitted.
select rank(this)
rank(0)
rnk = 0
@@ -58,6 +67,13 @@ function rank_a(this) result(rnk) bind(c)
integer(kind=c_int), allocatable, intent(in) :: this(..)
integer(kind=c_int) :: rnk
+ if (.not. allocated (this)) then
+ rnk = rank (this)
+ return
+ end if
+
+ ! Only valid when allocated
+ ! As otherweise, only inquiry functions permitted.
select rank(this)
rank(0)
rnk = 0
@@ -97,27 +113,60 @@ function rank_a(this) result(rnk) bind(c)
return
end function rank_a
-program selr_p
-
+function rank_o(this) result(rnk) bind(c)
use, intrinsic :: iso_c_binding, only: c_int
implicit none
+
+ integer(kind=c_int), intent(in) :: this(..)
+ integer(kind=c_int) :: rnk
- interface
- function rank_p(this) result(rnk) bind(c)
- use, intrinsic :: iso_c_binding, only: c_int
- integer(kind=c_int), pointer, intent(in) :: this(..)
- integer(kind=c_int) :: rnk
- end function rank_p
- end interface
-
- interface
- function rank_a(this) result(rnk) bind(c)
- use, intrinsic :: iso_c_binding, only: c_int
- integer(kind=c_int), allocatable, intent(in) :: this(..)
- integer(kind=c_int) :: rnk
- end function rank_a
- end interface
+ select rank(this)
+ rank(0)
+ rnk = 0
+ rank(1)
+ rnk = 1
+ rank(2)
+ rnk = 2
+ rank(3)
+ rnk = 3
+ rank(4)
+ rnk = 4
+ rank(5)
+ rnk = 5
+ rank(6)
+ rnk = 6
+ rank(7)
+ rnk = 7
+ rank(8)
+ rnk = 8
+ rank(9)
+ rnk = 9
+ rank(10)
+ rnk = 10
+ rank(11)
+ rnk = 11
+ rank(12)
+ rnk = 12
+ rank(13)
+ rnk = 13
+ rank(14)
+ rnk = 14
+ rank(15)
+ rnk = 15
+ rank default
+ rnk = -1000
+ end select
+ return
+end function rank_o
+
+end module m
+
+program selr_p
+ use m
+ use, intrinsic :: iso_c_binding, only: c_int
+
+ implicit none
integer(kind=c_int), parameter :: siz = 7
integer(kind=c_int), parameter :: rnk = 1
@@ -139,12 +188,19 @@ program selr_p
irnk = rank_p(intp)
if (irnk /= rnk) stop 5
if (irnk /= rank(intp)) stop 6
+ irnk = rank_o(intp)
+ if (irnk /= rnk) stop 7
+ if (irnk /= rank(intp)) stop 8
deallocate(intp)
nullify(intp)
!
allocate(inta(siz))
- if (irnk /= rnk) stop 7
- if (irnk /= rank(inta)) stop 8
+ irnk = rank_a(inta)
+ if (irnk /= rnk) stop 9
+ if (irnk /= rank(inta)) stop 10
+ irnk = rank_o(inta)
+ if (irnk /= rnk) stop 11
+ if (irnk /= rank(inta)) stop 12
deallocate(inta)
end program selr_p
new file mode 100644
@@ -0,0 +1,35 @@
+! PR fortran/102086
+
+implicit none (type, external)
+contains
+subroutine as(a)
+ type(*) :: a(:,:)
+end
+subroutine ar(b)
+ type(*) :: b(..)
+end
+subroutine bar(x,y)
+ type(*) :: x
+ type(*) :: y(3,*)
+ call as(x) ! { dg-error "Rank mismatch in argument 'a' at .1. \\(rank-2 and scalar\\)" }
+ call ar(x) ! { dg-error "Assumed-type actual argument at .1. must be of assumed rank or assumed shape as dummy argument 'b' has assumed rank" }
+ call as(y) ! { dg-error "Actual argument for 'a' cannot be an assumed-size array" }
+ call ar(y) ! { dg-error "Assumed-type actual argument at .1. must be of assumed rank or assumed shape as dummy argument 'b' has assumed rank" }
+ call as(y(1,3)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" }
+ call ar(y(1,3)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" }
+ call as(y(1:1,3:3)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" }
+ call ar(y(1:1,3:3)) ! { dg-error "Assumed-type variable y at .1. shall not have a subobject reference" }
+end
+
+subroutine okayish(x,y,z)
+ type(*) :: x(:)
+ type(*) :: y(:,:)
+ type(*) :: z(..)
+ call as(x) ! { dg-error "Rank mismatch in argument 'a' at .1. \\(rank-2 and rank-1\\)" }
+ call as(y)
+ call as(z) ! { dg-error "The assumed-rank array at .1. requires that the dummy argument 'a' has assumed-rank" }
+ call ar(x)
+ call ar(y)
+ call ar(z)
+end
+end
@@ -32,11 +32,14 @@ program p
end program p
! "cfi" only appears in context of "a" -> bind-C descriptor
-! the intent(out) implies freeing in the callee (!), hence the "free"
+! the intent(out) implies freeing in the callee (!) (when implemented in Fortran), hence the "free"
+! and also in the caller (when implemented in Fortran)
! It is the only 'free' as 'a' is part of the main program and, hence, implicitly has the SAVE attribute.
! The 'cfi = 0' appears before the call due to the deallocate and when preparing the C descriptor
! As cfi (i.e. the descriptor itself) is allocated in libgomp, it has to be freed after the call.
! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } }
-! { dg-final { scan-tree-dump-times "__builtin_free \\(cfi\\.\[0-9\]+\\);" 2 "original" } }
-! { dg-final { scan-tree-dump-times "cfi\\.\[0-9\]+ = 0B;" 2 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free \\(_x->base_addr\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_x->base_addr = 0B;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free \\(cfi\\.\[0-9\]+\\.base_addr\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "cfi\\.\[0-9\]+\\.base_addr = 0B;" 1 "original" } }
@@ -22,4 +22,32 @@ end
! { dg-final { scan-assembler-times "brasl\t%r\[0-9\]*,myBindC" 1 { target { s390*-*-* } } } }
! { dg-final { scan-assembler-times "bl \.myBindC" 1 { target { powerpc-ibm-aix* } } } }
! { dg-final { scan-assembler-times "add_u32\t\[sv\]\[0-9\]*, \[sv\]\[0-9\]*, myBindC@rel32@lo" 1 { target { amdgcn*-*-* } } } }
-! { dg-final { scan-tree-dump-times "gfc_desc_to_cfi_desc \\\(&cfi\\." 1 "original" } }
+
+
+! { dg-final { scan-tree-dump "parm...span = 4;" "original" } }
+! { dg-final { scan-tree-dump "parm...dtype = {.elem_len=4, .rank=2, .type=1};" "original" } }
+! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].lbound = 1;" "original" } }
+! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].ubound = 4;" "original" } }
+! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].stride = 1;" "original" } }
+! { dg-final { scan-tree-dump "parm...dim\\\[1\\\].lbound = 1;" "original" } }
+! { dg-final { scan-tree-dump "parm...dim\\\[1\\\].ubound = 4;" "original" } }
+! { dg-final { scan-tree-dump "parm...dim\\\[1\\\].stride = 4;" "original" } }
+! { dg-final { scan-tree-dump "parm...data = \\(void \\*\\) &aa\\\[0\\\];" "original" } }
+! { dg-final { scan-tree-dump "parm...offset = -5;" "original" } }
+! { dg-final { scan-tree-dump "cfi...version = 1;" "original" } }
+! { dg-final { scan-tree-dump "cfi...rank = 2;" "original" } }
+! { dg-final { scan-tree-dump "cfi...type = 1025;" "original" } }
+! { dg-final { scan-tree-dump "cfi...attribute = 2;" "original" } }
+! { dg-final { scan-tree-dump "cfi...base_addr = parm.0.data;" "original" } }
+! { dg-final { scan-tree-dump "cfi...elem_len = 4;" "original" } }
+! { dg-final { scan-tree-dump "idx.2 = 0;" "original" } }
+
+! { dg-final { scan-tree-dump "if \\(idx.. > 1\\) goto L..;" "original" } }
+! { dg-final { scan-tree-dump "cfi...dim\\\[idx..\\\].lower_bound = 0;" "original" } }
+! { dg-final { scan-tree-dump "cfi...dim\\\[idx..\\\].extent = \\(parm...dim\\\[idx..\\\].ubound - parm...dim\\\[idx..\\\].lbound\\) \\+ 1;" "original" } }
+! { dg-final { scan-tree-dump "cfi...dim\\\[idx..\\\].sm = parm...dim\\\[idx..\\\].stride \\* parm...span;" "original" } }
+! { dg-final { scan-tree-dump "idx.. = idx.. \\+ 1;" "original" } }
+
+! { dg-final { scan-tree-dump "test \\(&cfi..\\);" "original" } }
+
+
@@ -466,15 +466,16 @@ program main
end
! All arguments shall use array descriptors
-! { dg-final { scan-tree-dump-times "void as1 \\(struct array01_character\\(kind=1\\) & restrict x1\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void as2 \\(struct array01_character\\(kind=1\\) & restrict x2\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void as4 \\(struct array01_character\\(kind=1\\) & restrict xstar\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void as3 \\(struct array01_character\\(kind=1\\) & restrict xn, integer(kind=4) & restrict n)
-! { dg-final { scan-tree-dump-times "void ar1 \\(struct array15_character\\(kind=1\\) & restrict x1\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void ar2 \\(struct array15_character\\(kind=1\\) & restrict x2\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void ar3 \\(struct array15_character\\(kind=1\\) & restrict xn, integer(kind=4) & restrict n)
-! { dg-final { scan-tree-dump-times "void ar4 \\(struct array15_character\\(kind=1\\) & restrict xstar\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void a5a \\(struct array01_character\\(kind=1\\) & restrict xcolon\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void a5ar \\(struct array15_character\\(kind=1\\) & restrict xcolon\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void a5p \\(struct array01_character\\(kind=1\\) & xcolon\\)" 1 "original" } }
-! { dg-final { scan-tree-dump-times "void a5pr \\(struct array15_character\\(kind=1\\) & xcolon\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void as1 \\(struct CFI_cdesc_t01 & restrict _x1\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void as2 \\(struct CFI_cdesc_t01 & restrict _x2\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void as3 \\(struct CFI_cdesc_t01 & restrict _xn, integer\\(kind=4\\) & restrict n\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void as4 \\(struct CFI_cdesc_t01 & restrict _xstar\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void ar1 \\(struct CFI_cdesc_t & restrict _x1\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void ar2 \\(struct CFI_cdesc_t & restrict _x2\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void ar3 \\(struct CFI_cdesc_t & restrict _xn, integer\\(kind=4\\) & restrict n\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void ar4 \\(struct CFI_cdesc_t & restrict _xstar\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void a5ar \\(struct CFI_cdesc_t & restrict _xcolon\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void a5a \\(struct CFI_cdesc_t01 & restrict _xcolon\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void a5pr \\(struct CFI_cdesc_t & _xcolon\\)" 1 "original" } }
+! { dg-final { scan-tree-dump-times "void a5p \\(struct CFI_cdesc_t01 & _xcolon\\)" 1 "original" } }
+
@@ -34,6 +34,8 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
extern void cfi_desc_to_gfc_desc (gfc_array_void *, CFI_cdesc_t **);
export_proto(cfi_desc_to_gfc_desc);
+/* NOTE: Since GCC 12, the FE generates code to do the conversion
+ directly without calling this function. */
void
cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
{
@@ -111,6 +113,8 @@ cfi_desc_to_gfc_desc (gfc_array_void *d, CFI_cdesc_t **s_ptr)
extern void gfc_desc_to_cfi_desc (CFI_cdesc_t **, const gfc_array_void *);
export_proto(gfc_desc_to_cfi_desc);
+/* NOTE: Since GCC 12, the FE generates code to do the conversion
+ directly without calling this function. */
void
gfc_desc_to_cfi_desc (CFI_cdesc_t **d_ptr, const gfc_array_void *s)
{