public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-4467] Fortran: Fix Bind(C) Array-Descriptor Conversion
@ 2021-10-18 8:29 Tobias Burnus
0 siblings, 0 replies; only message in thread
From: Tobias Burnus @ 2021-10-18 8:29 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:64f9623765da3306b0ab6a47997dc5d62c2ea261
commit r12-4467-g64f9623765da3306b0ab6a47997dc5d62c2ea261
Author: Tobias Burnus <tobias@codesourcery.com>
Date: Mon Oct 18 09:51:36 2021 +0200
Fortran: Fix Bind(C) Array-Descriptor Conversion
gfortran uses internally a different array descriptor ("gfc") as
Fortran 2018 alias TS291113 defines for C interoperability via
ISO_Fortran_binding.h ("CFI"). Hence, when calling a C function
from Fortran, it has to be converted in the callee - and if a
BIND(C) procedure is written in Fortran, the CFI argument has
to be converted to gfc in order work with the rest of the FE
code and the library calls.
Before this patch, part was handled in the FE generated code and
other parts in libgfortran. With this patch, all code is generated
and CFI is defined as proper type - visible in the debugger and to
the middle end - avoiding both alias issues and missed optimization
issues.
This patch also fixes issues like: intent(out) deallocation in
the bind(C) callee, using the CFI descriptor also for allocatable
and pointer scalars and for len=* character strings.
For 'select rank', it also optimizes the code + avoid accessing
uninitialized memory if the dummy argument is allocatable/a pointer.
It additionally rejects passing a descriptorless type(*) to an
assumed-rank dummy argument. [F2018:C711]
PR fortran/102086
PR fortran/92189
PR fortran/92621
PR fortran/101308
PR fortran/101309
PR fortran/101635
PR fortran/92482
gcc/fortran/ChangeLog:
* decl.c (gfc_verify_c_interop_param): Remove 'sorry' for
scalar allocatable/pointer and len=*.
* expr.c (is_CFI_desc): Return true for for those.
* gfortran.h (CFI_type_kind_shift, CFI_type_mask,
CFI_type_from_type_kind, CFI_VERSION, CFI_MAX_RANK,
CFI_attribute_pointer, CFI_attribute_allocatable,
CFI_attribute_other, CFI_type_Integer, CFI_type_Logical,
CFI_type_Real, CFI_type_Complex, CFI_type_Character,
CFI_type_ucs4_char, CFI_type_struct, CFI_type_cptr,
CFI_type_cfunptr, CFI_type_other): New #define.
* trans-array.c (CFI_FIELD_BASE_ADDR, CFI_FIELD_ELEM_LEN,
CFI_FIELD_VERSION, CFI_FIELD_RANK, CFI_FIELD_ATTRIBUTE,
CFI_FIELD_TYPE, CFI_FIELD_DIM, CFI_DIM_FIELD_LOWER_BOUND,
CFI_DIM_FIELD_EXTENT, CFI_DIM_FIELD_SM,
gfc_get_cfi_descriptor_field, gfc_get_cfi_desc_base_addr,
gfc_get_cfi_desc_elem_len, gfc_get_cfi_desc_version,
gfc_get_cfi_desc_rank, gfc_get_cfi_desc_type,
gfc_get_cfi_desc_attribute, gfc_get_cfi_dim_item,
gfc_get_cfi_dim_lbound, gfc_get_cfi_dim_extent, gfc_get_cfi_dim_sm):
New define/functions to access the CFI array descriptor.
(gfc_conv_descriptor_type): New function for the GFC descriptor.
(gfc_get_array_span): Handle expr of CFI descriptors and
assumed-type descriptors.
(gfc_trans_array_bounds): Remove 'static'.
(gfc_conv_expr_descriptor): For assumed type, use the dtype of
the actual argument.
(structure_alloc_comps): Remove ' ' inside tabs.
* trans-array.h (gfc_trans_array_bounds, gfc_conv_descriptor_type,
gfc_get_cfi_desc_base_addr, gfc_get_cfi_desc_elem_len,
gfc_get_cfi_desc_version, gfc_get_cfi_desc_rank,
gfc_get_cfi_desc_type, gfc_get_cfi_desc_attribute,
gfc_get_cfi_dim_lbound, gfc_get_cfi_dim_extent, gfc_get_cfi_dim_sm):
New prototypes.
* trans-decl.c (gfor_fndecl_cfi_to_gfc, gfor_fndecl_gfc_to_cfi):
Remove global vars.
(gfc_build_builtin_function_decls): Remove their initialization.
(gfc_get_symbol_decl, create_function_arglist,
gfc_trans_deferred_vars): Update for CFI.
(convert_CFI_desc): Remove and replace by ...
(gfc_conv_cfi_to_gfc): ... this function
(gfc_generate_function_code): Call it; create local GFC var for CFI.
* trans-expr.c (gfc_maybe_dereference_var): Handle CFI.
(gfc_conv_subref_array_arg): Handle the if-noncontigous-only copy in
when the result should be a descriptor.
(gfc_conv_gfc_desc_to_cfi_desc): Completely rewritten.
(gfc_conv_procedure_call): CFI fixes.
* trans-openmp.c (gfc_omp_is_optional_argument,
gfc_omp_check_optional_argument): Handle optional
CFI.
* trans-stmt.c (gfc_trans_select_rank_cases): Cleanup, avoid invalid
code for allocatable/pointer dummies, which cannot be assumed size.
* trans-types.c (gfc_cfi_descriptor_base): New global var.
(gfc_get_dtype_rank_type): Skip rank init for rank < 0.
(gfc_sym_type): Handle CFI dummies.
(gfc_get_function_type): Update call.
(gfc_get_cfi_dim_type, gfc_get_cfi_type): New.
* trans-types.h (gfc_sym_type): Update prototype.
(gfc_get_cfi_type): New prototype.
* trans.c (gfc_trans_runtime_check): Make conditions more consistent
to avoid '<logical> AND_THEN <long int>' in conditions.
* trans.h (gfor_fndecl_cfi_to_gfc, gfor_fndecl_gfc_to_cfi): Remove
global-var declaration.
libgfortran/ChangeLog:
* ISO_Fortran_binding.h (CFI_type_cfunptr): Make unique type again.
* runtime/ISO_Fortran_binding.c (cfi_desc_to_gfc_desc,
gfc_desc_to_cfi_desc): Add comment that those are no longer called
by new code.
libgomp/ChangeLog:
* testsuite/libgomp.fortran/optional-bind-c.f90: New test.
gcc/testsuite/ChangeLog:
* gfortran.dg/ISO_Fortran_binding_4.f90: Extend testcase.
* gfortran.dg/PR100914.f90: Remove xfail.
* gfortran.dg/PR100915.c: Expect CFI_type_cfunptr.
* gfortran.dg/PR100915.f90: Handle CFI_type_cfunptr != CFI_type_cptr.
* gfortran.dg/PR93963.f90: Extend select-rank tests.
* gfortran.dg/bind-c-intent-out.f90: Change to dg-do run,
update scan-dump.
* gfortran.dg/bind_c_array_params_2.f90: Update/extend scan-dump.
* gfortran.dg/bind_c_char_10.f90: Update scan-dump.
* gfortran.dg/bind_c_char_8.f90: Remove dg-error "sorry".
* gfortran.dg/c-interop/allocatable-dummy.f90: Remove xfail.
* gfortran.dg/c-interop/c1255-1.f90: Likewise.
* gfortran.dg/c-interop/c407c-1.f90: Update dg-error.
* gfortran.dg/c-interop/cf-descriptor-5.f90: Remove xfail.
* gfortran.dg/c-interop/cf-out-descriptor-3.f90: Likewise.
* gfortran.dg/c-interop/cf-out-descriptor-4.f90: Likewise.
* gfortran.dg/c-interop/cf-out-descriptor-5.f90: Likewise.
* gfortran.dg/c-interop/contiguous-2.f90: Likewise.
* gfortran.dg/c-interop/contiguous-3.f90: Likewise.
* gfortran.dg/c-interop/deferred-character-1.f90: Likewise.
* gfortran.dg/c-interop/deferred-character-2.f90: Likewise.
* gfortran.dg/c-interop/fc-descriptor-3.f90: Likewise.
* gfortran.dg/c-interop/fc-descriptor-5.f90: Likewise.
* gfortran.dg/c-interop/fc-descriptor-6.f90: Likewise.
* gfortran.dg/c-interop/fc-out-descriptor-3.f90: Likewise.
* gfortran.dg/c-interop/fc-out-descriptor-4.f90: Likewise.
* gfortran.dg/c-interop/fc-out-descriptor-5.f90: Likewise.
* gfortran.dg/c-interop/fc-out-descriptor-6.f90: Likewise.
* gfortran.dg/c-interop/ff-descriptor-5.f90: Likewise.
* gfortran.dg/c-interop/ff-descriptor-6.f90: Likewise.
* gfortran.dg/c-interop/fc-descriptor-7.f90: Remove xfail + extend.
* gfortran.dg/c-interop/fc-descriptor-7-c.c: Update for changes.
* gfortran.dg/c-interop/shape.f90: Add implicit none.
* gfortran.dg/c-interop/typecodes-array-char-c.c: Add kind=4 char.
* gfortran.dg/c-interop/typecodes-array-char.f90: Likewise.
* gfortran.dg/c-interop/typecodes-array-float128.f90: Remove xfail.
* gfortran.dg/c-interop/typecodes-scalar-basic.f90: Likewise.
* gfortran.dg/c-interop/typecodes-scalar-float128.f90: Likewise.
* gfortran.dg/c-interop/typecodes-scalar-int128.f90: Likewise.
* gfortran.dg/c-interop/typecodes-scalar-longdouble.f90: Likewise.
* gfortran.dg/iso_c_binding_char_1.f90: Remove dg-error "sorry".
* gfortran.dg/pr93792.f90: Turn XFAIL into PASS.
* gfortran.dg/ISO_Fortran_binding_19.f90: New test.
* gfortran.dg/assumed_type_12.f90: New test.
* gfortran.dg/assumed_type_13.c: New test.
* gfortran.dg/assumed_type_13.f90: New test.
* gfortran.dg/bind-c-char-descr.f90: New test.
* gfortran.dg/bind-c-contiguous-1.c: New test.
* gfortran.dg/bind-c-contiguous-1.f90: New test.
* gfortran.dg/bind-c-contiguous-2.f90: New test.
* gfortran.dg/bind-c-contiguous-3.c: New test.
* gfortran.dg/bind-c-contiguous-3.f90: New test.
* gfortran.dg/bind-c-contiguous-4.c: New test.
* gfortran.dg/bind-c-contiguous-4.f90: New test.
* gfortran.dg/bind-c-contiguous-5.c: New test.
* gfortran.dg/bind-c-contiguous-5.f90: New test.
Diff:
---
gcc/fortran/decl.c | 23 -
gcc/fortran/expr.c | 8 +-
gcc/fortran/gfortran.h | 34 +
gcc/fortran/trans-array.c | 146 +-
gcc/fortran/trans-array.h | 16 +-
gcc/fortran/trans-decl.c | 1028 ++++++++++--
gcc/fortran/trans-expr.c | 625 +++++--
gcc/fortran/trans-openmp.c | 6 +-
gcc/fortran/trans-stmt.c | 44 +-
gcc/fortran/trans-types.c | 107 +-
gcc/fortran/trans-types.h | 3 +-
gcc/fortran/trans.c | 11 +-
gcc/fortran/trans.h | 2 -
.../gfortran.dg/ISO_Fortran_binding_19.f90 | 28 +
.../gfortran.dg/ISO_Fortran_binding_4.f90 | 22 +-
gcc/testsuite/gfortran.dg/PR100914.f90 | 2 +-
gcc/testsuite/gfortran.dg/PR100915.c | 2 +-
gcc/testsuite/gfortran.dg/PR100915.f90 | 13 +-
gcc/testsuite/gfortran.dg/PR93963.f90 | 80 +-
gcc/testsuite/gfortran.dg/assumed_type_12.f90 | 34 +
gcc/testsuite/gfortran.dg/assumed_type_13.c | 26 +
gcc/testsuite/gfortran.dg/assumed_type_13.f90 | 66 +
gcc/testsuite/gfortran.dg/bind-c-char-descr.f90 | 104 ++
gcc/testsuite/gfortran.dg/bind-c-contiguous-1.c | 345 ++++
gcc/testsuite/gfortran.dg/bind-c-contiguous-1.f90 | 1574 ++++++++++++++++++
gcc/testsuite/gfortran.dg/bind-c-contiguous-2.f90 | 82 +
gcc/testsuite/gfortran.dg/bind-c-contiguous-3.c | 180 ++
gcc/testsuite/gfortran.dg/bind-c-contiguous-3.f90 | 656 ++++++++
gcc/testsuite/gfortran.dg/bind-c-contiguous-4.c | 370 +++++
gcc/testsuite/gfortran.dg/bind-c-contiguous-4.f90 | 1720 ++++++++++++++++++++
gcc/testsuite/gfortran.dg/bind-c-contiguous-5.c | 345 ++++
gcc/testsuite/gfortran.dg/bind-c-contiguous-5.f90 | 1574 ++++++++++++++++++
gcc/testsuite/gfortran.dg/bind-c-intent-out.f90 | 13 +-
.../gfortran.dg/bind_c_array_params_2.f90 | 30 +-
gcc/testsuite/gfortran.dg/bind_c_char_10.f90 | 25 +-
gcc/testsuite/gfortran.dg/bind_c_char_8.f90 | 10 +-
.../gfortran.dg/c-interop/allocatable-dummy.f90 | 2 +-
gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90 | 2 +-
gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90 | 2 +-
.../gfortran.dg/c-interop/cf-descriptor-5.f90 | 2 +-
.../gfortran.dg/c-interop/cf-out-descriptor-3.f90 | 2 +-
.../gfortran.dg/c-interop/cf-out-descriptor-4.f90 | 2 +-
.../gfortran.dg/c-interop/cf-out-descriptor-5.f90 | 6 +-
.../gfortran.dg/c-interop/contiguous-2.f90 | 2 +-
.../gfortran.dg/c-interop/contiguous-3.f90 | 2 +-
.../gfortran.dg/c-interop/deferred-character-1.f90 | 4 +-
.../gfortran.dg/c-interop/deferred-character-2.f90 | 2 +-
.../gfortran.dg/c-interop/fc-descriptor-3.f90 | 2 +-
.../gfortran.dg/c-interop/fc-descriptor-5.f90 | 2 +-
.../gfortran.dg/c-interop/fc-descriptor-6.f90 | 2 +-
.../gfortran.dg/c-interop/fc-descriptor-7-c.c | 27 +-
.../gfortran.dg/c-interop/fc-descriptor-7.f90 | 134 +-
.../gfortran.dg/c-interop/fc-out-descriptor-3.f90 | 2 +-
.../gfortran.dg/c-interop/fc-out-descriptor-4.f90 | 2 +-
.../gfortran.dg/c-interop/fc-out-descriptor-5.f90 | 4 +-
.../gfortran.dg/c-interop/fc-out-descriptor-6.f90 | 2 +-
.../gfortran.dg/c-interop/ff-descriptor-5.f90 | 4 +-
.../gfortran.dg/c-interop/ff-descriptor-6.f90 | 2 +-
gcc/testsuite/gfortran.dg/c-interop/shape.f90 | 4 +-
.../gfortran.dg/c-interop/typecodes-array-char-c.c | 6 +
.../gfortran.dg/c-interop/typecodes-array-char.f90 | 10 +
.../c-interop/typecodes-array-float128.f90 | 2 +-
.../c-interop/typecodes-scalar-basic.f90 | 2 +-
.../c-interop/typecodes-scalar-float128.f90 | 2 +-
.../c-interop/typecodes-scalar-int128.f90 | 2 +-
.../c-interop/typecodes-scalar-longdouble.f90 | 2 +-
gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 | 3 +-
gcc/testsuite/gfortran.dg/pr93792.f90 | 2 +-
libgfortran/ISO_Fortran_binding.h | 8 +-
libgfortran/runtime/ISO_Fortran_binding.c | 4 +
.../testsuite/libgomp.fortran/optional-bind-c.f90 | 18 +
71 files changed, 9149 insertions(+), 481 deletions(-)
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 86adb81da32..6784b07ae9e 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -1605,15 +1605,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
@@ -1636,20 +1627,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
|| mpz_cmp_si (cl->length->value.integer, 1) != 0)
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 6c38935adc3..66f24c63823 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1110,11 +1110,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;
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 5b9f89748d2..66192c07d8c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -105,6 +105,40 @@ 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_mask 0xFF
+#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
+
+/* Combined type (for more, see ISO_Fortran_binding.h). */
+#define CFI_type_ucs4_char (CFI_type_Character + (4 << CFI_type_kind_shift))
+
+/* 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 *****************************/
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 0c5cf4b19a0..f8c087e3ac5 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -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)
{
@@ -825,7 +944,11 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
{
tree tmp;
- if (is_pointer_array (desc) || get_CFI_desc (NULL, expr, &desc, NULL))
+ if (is_pointer_array (desc)
+ || (get_CFI_desc (NULL, expr, &desc, NULL)
+ && (POINTER_TYPE_P (TREE_TYPE (desc))
+ ? GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc)))
+ : GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))))
{
if (POINTER_TYPE_P (TREE_TYPE (desc)))
desc = build_fold_indirect_ref_loc (input_location, desc);
@@ -833,6 +956,14 @@ gfc_get_array_span (tree desc, gfc_expr *expr)
/* This will have the span field set. */
tmp = gfc_conv_descriptor_span_get (desc);
}
+ else if (expr->ts.type == BT_ASSUMED)
+ {
+ if (DECL_LANG_SPECIFIC (desc) && GFC_DECL_SAVED_DESCRIPTOR (desc))
+ desc = GFC_DECL_SAVED_DESCRIPTOR (desc);
+ if (POINTER_TYPE_P (TREE_TYPE (desc)))
+ desc = build_fold_indirect_ref_loc (input_location, desc);
+ tmp = gfc_conv_descriptor_span_get (desc);
+ }
else if (TREE_CODE (desc) == COMPONENT_REF
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
&& GFC_CLASS_TYPE_P (TREE_TYPE (TREE_OPERAND (desc, 0))))
@@ -6286,7 +6417,7 @@ gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
/* Generate code to evaluate non-constant array bounds. Sets *poffset and
returns the size (in elements) of the array. */
-static tree
+tree
gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
stmtblock_t * pblock)
{
@@ -7755,6 +7886,15 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
tmp = gfc_conv_descriptor_dtype (parm);
if (se->unlimited_polymorphic)
dtype = gfc_get_dtype (TREE_TYPE (desc), &loop.dimen);
+ else if (expr->ts.type == BT_ASSUMED)
+ {
+ tree tmp2 = desc;
+ if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
+ tmp2 = GFC_DECL_SAVED_DESCRIPTOR (tmp2);
+ if (POINTER_TYPE_P (TREE_TYPE (tmp2)))
+ tmp2 = build_fold_indirect_ref_loc (input_location, tmp2);
+ dtype = gfc_conv_descriptor_dtype (tmp2);
+ }
else
dtype = gfc_get_dtype (parmtype);
gfc_add_modify (&loop.pre, tmp, dtype);
@@ -9006,7 +9146,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
DECL_ARTIFICIAL (cdesc) = 1;
gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
- gfc_get_dtype_rank_type (1, tmp));
+ gfc_get_dtype_rank_type (1, tmp));
gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
gfc_index_zero_node,
gfc_index_one_node);
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 85ff2161191..1d3dc4819eb 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -160,7 +160,8 @@ tree gfc_conv_array_stride (tree, int);
tree gfc_conv_array_lbound (tree, int);
tree gfc_conv_array_ubound (tree, int);
-/* Set cobounds of an array. */
+/* Set (co)bounds of an array. */
+tree gfc_trans_array_bounds (tree, gfc_symbol *, tree *, stmtblock_t *);
void gfc_trans_array_cobounds (tree, stmtblock_t *, const gfc_symbol *);
/* Build expressions for accessing components of an array descriptor. */
@@ -175,6 +176,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);
@@ -188,6 +190,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);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 7da1d2ebdcf..de624c82fcf 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -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)
@@ -2759,9 +2762,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 for the parm_decl and inside the proc 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_)
{
@@ -3832,19 +3845,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);
@@ -4462,115 +4462,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
@@ -5147,13 +5038,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);
@@ -6777,6 +6661,788 @@ 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, idx, etype, tmp, tmp2, size_var = NULL_TREE;
+ bool do_copy_inout = false;
+
+ /* 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));
+ }
+
+ /* -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);
+
+ /* Rank check; however, for character(len=*), assumed/explicit-size arrays
+ are permitted to differ in rank according to the Fortran rules. */
+ if (sym->as && sym->as->type != AS_ASSUMED_SIZE
+ && sym->as->type != AS_EXPLICIT)
+ {
+ if (sym->as->rank != -1)
+ msg = xasprintf ("Invalid rank %%d (expected %d) in CFI descriptor "
+ "passed to dummy argument %s", sym->as->rank,
+ sym->name);
+ else
+ 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);
+ if (sym->as->rank != -1)
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, build_int_cst (signed_char_type_node,
+ sym->as->rank));
+ else
+ {
+ tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ tmp, build_zero_cst (TREE_TYPE (tmp)));
+ 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 dummy argument %s with %s "
+ "attribute", attr, sym->name,
+ sym->attr.pointer ? "pointer" : "allocatable");
+ 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 (CFI_type_Character,
+ 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);
+ }
+ }
+
+ 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.
+ assumed-size/explicit-size arrays end up here for character(len=*)
+ only. */
+ if (!sym->attr.dimension || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+ {
+ tmp = gfc_get_cfi_desc_base_addr (cfi);
+ gfc_add_modify (&block, gfc_desc,
+ fold_convert (TREE_TYPE (gfc_desc), tmp));
+ if (!sym->attr.dimension)
+ goto done;
+ }
+
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+ {
+ /* 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));
+ }
+
+ if (sym->ts.type == BT_ASSUMED)
+ {
+ /* For type(*), take elem_len + dtype.type from the actual argument. */
+ gfc_add_modify (&block, gfc_conv_descriptor_elem_len (gfc_desc),
+ gfc_get_cfi_desc_elem_len (cfi));
+ tree cond;
+ tree ctype = gfc_get_cfi_desc_type (cfi);
+ ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
+ ctype, build_int_cst (TREE_TYPE (ctype),
+ CFI_type_mask));
+ tree type = gfc_conv_descriptor_type (gfc_desc);
+
+ /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */
+ /* 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, ctype,
+ build_int_cst (TREE_TYPE (ctype), CFI_type_cptr));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
+ build_int_cst (TREE_TYPE (type), BT_VOID));
+ tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ type,
+ build_int_cst (TREE_TYPE (type), BT_UNKNOWN));
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+ /* if (CFI_type_struct) BT_DERIVED else < tmp2 > */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+ build_int_cst (TREE_TYPE (ctype),
+ CFI_type_struct));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
+ build_int_cst (TREE_TYPE (type), BT_DERIVED));
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+ /* if (CFI_type_Character) BT_CHARACTER else < tmp2 > */
+ /* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if'
+ before (see below, as generated bottom up). */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+ build_int_cst (TREE_TYPE (ctype),
+ CFI_type_Character));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
+ build_int_cst (TREE_TYPE (type), BT_CHARACTER));
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+ /* if (CFI_type_ucs4_char) BT_CHARACTER else < tmp2 > */
+ /* Note: gfc->elem_len = cfi->elem_len/4. */
+ /* However, assuming that CFI_type_ucs4_char cannot be recovered, leave
+ gfc->elem_len == cfi->elem_len, which helps with operations which use
+ sizeof() in Fortran and cfi->elem_len in C. */
+ tmp = gfc_get_cfi_desc_type (cfi);
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
+ build_int_cst (TREE_TYPE (tmp),
+ CFI_type_ucs4_char));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
+ build_int_cst (TREE_TYPE (type), BT_CHARACTER));
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+ /* if (CFI_type_Complex) BT_COMPLEX + cfi->elem_len/2 else < tmp2 > */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+ build_int_cst (TREE_TYPE (ctype),
+ CFI_type_Complex));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
+ build_int_cst (TREE_TYPE (type), BT_COMPLEX));
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+ /* if (CFI_type_Integer || CFI_type_Logical || CFI_type_Real)
+ ctype else <tmp2> */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+ build_int_cst (TREE_TYPE (ctype),
+ CFI_type_Integer));
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype,
+ build_int_cst (TREE_TYPE (ctype),
+ CFI_type_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, ctype,
+ build_int_cst (TREE_TYPE (ctype),
+ CFI_type_Real));
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+ cond, tmp);
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ type, fold_convert (TREE_TYPE (type), ctype));
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+ gfc_add_expr_to_block (&block, tmp2);
+ }
+
+ if (sym->as->rank < 0)
+ {
+ /* Set gfc->dtype.rank, if assumed-rank. */
+ rank = gfc_get_cfi_desc_rank (cfi);
+ gfc_add_modify (&block, gfc_conv_descriptor_rank (gfc_desc), rank);
+ }
+ else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+ /* In that case, the CFI rank and the declared rank can differ. */
+ rank = gfc_get_cfi_desc_rank (cfi);
+ else
+ rank = build_int_cst (signed_char_type_node, sym->as->rank);
+
+ /* With bind(C), the standard requires that both Fortran callers and callees
+ handle noncontiguous arrays passed to an dummy with 'contiguous' attribute
+ and with character(len=*) + assumed-size/explicit-size arrays.
+ cf. Fortran 2018, 18.3.6, paragraph 5 (and for the caller: para. 6). */
+ if ((sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length
+ && (sym->as->type == AS_ASSUMED_SIZE || sym->as->type == AS_EXPLICIT))
+ || sym->attr.contiguous)
+ {
+ do_copy_inout = true;
+ gcc_assert (!sym->attr.pointer);
+ stmtblock_t block2;
+ tree data;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+ data = gfc_conv_descriptor_data_get (gfc_desc);
+ else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc)))
+ data = gfc_build_addr_expr (NULL, gfc_desc);
+ else
+ data = gfc_desc;
+
+ /* Is copy-in/out needed? */
+ /* do_copyin = rank != 0 && !assumed-size */
+ tree cond_var = gfc_create_var (boolean_type_node, "do_copyin");
+ tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ rank, build_zero_cst (TREE_TYPE (rank)));
+ /* dim[rank-1].extent != -1 -> assumed size*/
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (rank),
+ rank, build_int_cst (TREE_TYPE (rank), 1));
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ gfc_get_cfi_dim_extent (cfi, tmp),
+ build_int_cst (gfc_array_index_type, -1));
+ cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ boolean_type_node, cond, tmp);
+ gfc_add_modify (&block, cond_var, cond);
+ /* if (do_copyin) do_copyin = ... || ... || ... */
+ gfc_init_block (&block2);
+ /* dim[0].sm != elem_len */
+ tmp = fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi));
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ gfc_get_cfi_dim_sm (cfi, gfc_index_zero_node),
+ tmp);
+ gfc_add_modify (&block2, cond_var, cond);
+
+ /* for (i = 1; i < rank; ++i)
+ cond &&= dim[i].sm != (dv->dim[i - 1].sm * dv->dim[i - 1].extent) */
+ idx = gfc_create_var (TREE_TYPE (rank), "idx");
+ stmtblock_t loop_body;
+ gfc_init_block (&loop_body);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx),
+ idx, build_int_cst (TREE_TYPE (idx), 1));
+ tree tmp2 = gfc_get_cfi_dim_sm (cfi, tmp);
+ tmp = gfc_get_cfi_dim_extent (cfi, tmp);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
+ tmp2, tmp);
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ gfc_get_cfi_dim_sm (cfi, idx), tmp);
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+ cond_var, cond);
+ gfc_add_modify (&loop_body, cond_var, cond);
+ gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 1),
+ rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+ gfc_finish_block (&loop_body));
+ tmp = build3_v (COND_EXPR, cond_var, gfc_finish_block (&block2),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+
+ /* Copy-in body. */
+ gfc_init_block (&block2);
+ /* size = dim[0].extent; for (i = 1; i < rank; ++i) size *= dim[i].extent */
+ size_var = gfc_create_var (size_type_node, "size");
+ tmp = fold_convert (size_type_node,
+ gfc_get_cfi_dim_extent (cfi, gfc_index_zero_node));
+ gfc_add_modify (&block2, size_var, tmp);
+
+ gfc_init_block (&loop_body);
+ tmp = fold_convert (size_type_node,
+ gfc_get_cfi_dim_extent (cfi, idx));
+ tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ size_var, fold_convert (size_type_node, tmp));
+ gfc_add_modify (&loop_body, size_var, tmp);
+ gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 1),
+ rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+ gfc_finish_block (&loop_body));
+ /* data = malloc (size * elem_len) */
+ tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ size_var, gfc_get_cfi_desc_elem_len (cfi));
+ tree call = builtin_decl_explicit (BUILT_IN_MALLOC);
+ call = build_call_expr_loc (input_location, call, 1, tmp);
+ gfc_add_modify (&block2, data, fold_convert (TREE_TYPE (data), call));
+
+ /* Copy the data:
+ for (idx = 0; idx < size; ++idx)
+ {
+ shift = 0;
+ tmpidx = idx
+ for (dim = 0; dim < rank; ++dim)
+ {
+ shift += (tmpidx % extent[d]) * sm[d]
+ tmpidx = tmpidx / extend[d]
+ }
+ memcpy (lhs + idx*elem_len, rhs + shift, elem_len)
+ } .*/
+ idx = gfc_create_var (size_type_node, "arrayidx");
+ gfc_init_block (&loop_body);
+ tree shift = gfc_create_var (size_type_node, "shift");
+ tree tmpidx = gfc_create_var (size_type_node, "tmpidx");
+ gfc_add_modify (&loop_body, shift, build_zero_cst (TREE_TYPE (shift)));
+ gfc_add_modify (&loop_body, tmpidx, idx);
+ stmtblock_t inner_loop;
+ gfc_init_block (&inner_loop);
+ tree dim = gfc_create_var (TREE_TYPE (rank), "dim");
+ /* shift += (tmpidx % extent[d]) * sm[d] */
+ tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+ size_type_node, tmpidx,
+ fold_convert (size_type_node,
+ gfc_get_cfi_dim_extent (cfi, dim)));
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ size_type_node, tmp,
+ fold_convert (size_type_node,
+ gfc_get_cfi_dim_sm (cfi, dim)));
+ gfc_add_modify (&inner_loop, shift,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ size_type_node, shift, tmp));
+ /* tmpidx = tmpidx / extend[d] */
+ tmp = fold_convert (size_type_node, gfc_get_cfi_dim_extent (cfi, dim));
+ gfc_add_modify (&inner_loop, tmpidx,
+ fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ size_type_node, tmpidx, tmp));
+ gfc_simple_for_loop (&loop_body, dim, build_zero_cst (TREE_TYPE (rank)),
+ rank, LT_EXPR, build_int_cst (TREE_TYPE (dim), 1),
+ gfc_finish_block (&inner_loop));
+ /* Assign. */
+ tmp = fold_convert (pchar_type_node, gfc_get_cfi_desc_base_addr (cfi));
+ tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, tmp, shift);
+ tree lhs;
+ /* memcpy (lhs + idx*elem_len, rhs + shift, elem_len) */
+ tree elem_len;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+ elem_len = gfc_conv_descriptor_elem_len (gfc_desc);
+ else
+ elem_len = gfc_get_cfi_desc_elem_len (cfi);
+ lhs = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ elem_len, idx);
+ lhs = fold_build2_loc (input_location, POINTER_PLUS_EXPR, pchar_type_node,
+ fold_convert (pchar_type_node, data), lhs);
+ tmp = fold_convert (pvoid_type_node, tmp);
+ lhs = fold_convert (pvoid_type_node, lhs);
+ call = builtin_decl_explicit (BUILT_IN_MEMCPY);
+ call = build_call_expr_loc (input_location, call, 3, lhs, tmp, elem_len);
+ gfc_add_expr_to_block (&loop_body, fold_convert (void_type_node, call));
+ gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
+ size_var, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+ gfc_finish_block (&loop_body));
+ /* if (cond) { block2 } */
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ data, fold_convert (TREE_TYPE (data),
+ null_pointer_node));
+ tmp = build3_v (COND_EXPR, cond_var, gfc_finish_block (&block2),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
+ if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+ {
+ tree offset, type;
+ type = TREE_TYPE (gfc_desc);
+ gfc_trans_array_bounds (type, sym, &offset, &block);
+ if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type)))
+ gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ goto done;
+ }
+
+ /* If cfi->data != NULL. */
+ stmtblock_t block2;
+ gfc_init_block (&block2);
+
+ /* if do_copy_inout: gfc->dspan = gfc->dtype.elem_len
+ We use gfc instead of cfi on the RHS as this might be a constant. */
+ tmp = fold_convert (gfc_array_index_type,
+ gfc_conv_descriptor_elem_len (gfc_desc));
+ if (!do_copy_inout)
+ {
+ /* gfc->dspan = ((cfi->dim[0].sm % gfc->elem_len)
+ ? cfi->dim[0].sm : gfc->elem_len). */
+ tree cond;
+ tree tmp2 = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
+ cond = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+ gfc_array_index_type, tmp2, tmp);
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ cond, gfc_index_zero_node);
+ tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
+ tmp2, tmp);
+ }
+ 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). */
+ idx = gfc_create_var (TREE_TYPE (rank), "idx");
+
+ /* Loop body. */
+ stmtblock_t loop_body;
+ gfc_init_block (&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 (&loop_body, gfc_desc, idx, tmp);
+ }
+ else if (sym->as->rank < 0)
+ gfc_conv_descriptor_lbound_set (&loop_body, 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 (&loop_body, gfc_desc, idx, tmp);
+
+ if (do_copy_inout)
+ {
+ /* gfc->dim[i].stride
+ = idx == 0 ? 1 : gfc->dim[i-1].stride * cfi->dim[i-1].extent */
+ tree cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ idx, build_zero_cst (TREE_TYPE (idx)));
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx),
+ idx, build_int_cst (TREE_TYPE (idx), 1));
+ tree tmp2 = gfc_get_cfi_dim_extent (cfi, tmp);
+ tmp = gfc_conv_descriptor_stride_get (gfc_desc, tmp);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp2),
+ tmp2, tmp);
+ tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
+ gfc_index_one_node, tmp);
+ }
+ else
+ {
+ /* 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 (&loop_body, 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 (&loop_body, gfc_desc, tmp);
+
+ /* Generate loop. */
+ gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
+ rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+ gfc_finish_block (&loop_body));
+ 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);
+
+ if (!sym->attr.referenced)
+ return;
+
+ /* If pointer not changed, nothing to be done (except copy out) */
+ if (!do_copy_inout && ((!sym->attr.pointer && !sym->attr.allocatable)
+ || sym->attr.intent == INTENT_IN))
+ return;
+
+ gfc_init_block (&block);
+
+ /* For bind(C), Fortran does not permit mixing 'pointer' with 'contiguous' (or
+ len=*). Thus, when copy out is needed, the bounds ofthe descriptor remain
+ unchanged. */
+ if (do_copy_inout)
+ {
+ tree data, call;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+ data = gfc_conv_descriptor_data_get (gfc_desc);
+ else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc)))
+ data = gfc_build_addr_expr (NULL, gfc_desc);
+ else
+ data = gfc_desc;
+ gfc_init_block (&block2);
+ if (sym->attr.intent != INTENT_IN)
+ {
+ /* First, create the inner copy-out loop.
+ for (idx = 0; idx < size; ++idx)
+ {
+ shift = 0;
+ tmpidx = idx
+ for (dim = 0; dim < rank; ++dim)
+ {
+ shift += (tmpidx % extent[d]) * sm[d]
+ tmpidx = tmpidx / extend[d]
+ }
+ memcpy (lhs + shift, rhs + idx*elem_len, elem_len)
+ } .*/
+ stmtblock_t loop_body;
+ idx = gfc_create_var (size_type_node, "arrayidx");
+ gfc_init_block (&loop_body);
+ tree shift = gfc_create_var (size_type_node, "shift");
+ tree tmpidx = gfc_create_var (size_type_node, "tmpidx");
+ gfc_add_modify (&loop_body, shift,
+ build_zero_cst (TREE_TYPE (shift)));
+ gfc_add_modify (&loop_body, tmpidx, idx);
+ stmtblock_t inner_loop;
+ gfc_init_block (&inner_loop);
+ tree dim = gfc_create_var (TREE_TYPE (rank), "dim");
+ /* shift += (tmpidx % extent[d]) * sm[d] */
+ tmp = fold_convert (size_type_node,
+ gfc_get_cfi_dim_extent (cfi, dim));
+ tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+ size_type_node, tmpidx, tmp);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ size_type_node, tmp,
+ fold_convert (size_type_node,
+ gfc_get_cfi_dim_sm (cfi, dim)));
+ gfc_add_modify (&inner_loop, shift,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ size_type_node, shift, tmp));
+ /* tmpidx = tmpidx / extend[d] */
+ tmp = fold_convert (size_type_node,
+ gfc_get_cfi_dim_extent (cfi, dim));
+ gfc_add_modify (&inner_loop, tmpidx,
+ fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ size_type_node, tmpidx, tmp));
+ gfc_simple_for_loop (&loop_body, dim,
+ build_zero_cst (TREE_TYPE (rank)), rank, LT_EXPR,
+ build_int_cst (TREE_TYPE (dim), 1),
+ gfc_finish_block (&inner_loop));
+ /* Assign. */
+ tree rhs;
+ tmp = fold_convert (pchar_type_node,
+ gfc_get_cfi_desc_base_addr (cfi));
+ tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, tmp, shift);
+ /* memcpy (lhs + shift, rhs + idx*elem_len, elem_len) */
+ tree elem_len;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
+ elem_len = gfc_conv_descriptor_elem_len (gfc_desc);
+ else
+ elem_len = gfc_get_cfi_desc_elem_len (cfi);
+ rhs = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+ elem_len, idx);
+ rhs = fold_build2_loc (input_location, POINTER_PLUS_EXPR,
+ pchar_type_node,
+ fold_convert (pchar_type_node, data), rhs);
+ tmp = fold_convert (pvoid_type_node, tmp);
+ rhs = fold_convert (pvoid_type_node, rhs);
+ call = builtin_decl_explicit (BUILT_IN_MEMCPY);
+ call = build_call_expr_loc (input_location, call, 3, tmp, rhs,
+ elem_len);
+ gfc_add_expr_to_block (&loop_body,
+ fold_convert (void_type_node, call));
+ gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
+ size_var, LT_EXPR,
+ build_int_cst (TREE_TYPE (idx), 1),
+ gfc_finish_block (&loop_body));
+ }
+ call = builtin_decl_explicit (BUILT_IN_FREE);
+ call = build_call_expr_loc (input_location, call, 1, data);
+ gfc_add_expr_to_block (&block2, call);
+
+ /* if (cfi->base_addr != gfc->data) { copy out; free(var) }; return */
+ tree tmp2 = gfc_get_cfi_desc_base_addr (cfi);
+ tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp2, fold_convert (TREE_TYPE (tmp2), data));
+ tmp = build3_v (COND_EXPR, tmp2, gfc_finish_block (&block2),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ goto done_finally;
+ }
+
+ /* Update pointer + array data data on exit. */
+ 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). */
+ idx = gfc_create_var (TREE_TYPE (rank), "idx");
+
+ /* Loop body. */
+ gfc_init_block (&loop_body);
+ /* cfi->dim[i].lower_bound = gfc->dim[i].lbound */
+ gfc_add_modify (&loop_body, 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 (&loop_body, 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 (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
+
+ /* Generate loop. */
+ gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)),
+ rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+ gfc_finish_block (&loop_body));
+ /* 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. */
@@ -6788,7 +7454,7 @@ gfc_generate_function_code (gfc_namespace * ns)
tree decl;
tree tmp;
tree fpstate = NULL_TREE;
- stmtblock_t init, cleanup;
+ stmtblock_t init, cleanup, outer_block;
stmtblock_t body;
gfc_wrapped_block try_block;
tree recurcheckvar = NULL_TREE;
@@ -6822,6 +7488,8 @@ gfc_generate_function_code (gfc_namespace * ns)
trans_function_start (sym);
gfc_init_block (&init);
+ gfc_init_block (&cleanup);
+ gfc_init_block (&outer_block);
if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
{
@@ -6845,6 +7513,81 @@ 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;
+ }
+ /* 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)
+ 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 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc_p))))
+ {
+ /* Character(len=*) explict-size/assumed-size array. */
+ desc = desc_p;
+ gfc_build_qualified_array (desc, fsym);
+ }
+ else
+ {
+ tree size = size_in_bytes (TREE_TYPE (TREE_TYPE (desc_p)));
+ tree call = builtin_decl_explicit (BUILT_IN_ALLOCA);
+ call = build_call_expr_loc (input_location, call, 1, size);
+ gfc_add_modify (&outer_block, desc_p,
+ fold_convert (TREE_TYPE(desc_p), call));
+ desc = build_fold_indirect_ref_loc (input_location, desc_p);
+ }
+ pushdecl (desc_p);
+ if (fsym->attr.optional)
+ {
+ gfc_allocate_lang_decl (desc_p);
+ GFC_DECL_OPTIONAL_ARGUMENT (desc_p) = 1;
+ }
+ fsym->backend_decl = desc_p;
+ gfc_conv_cfi_to_gfc (&init, &cleanup, tmp, desc, fsym);
+ }
+
gfc_generate_contained_functions (ns);
has_coarray_vars = false;
@@ -6968,7 +7711,7 @@ gfc_generate_function_code (gfc_namespace * ns)
/* Arrays are not initialized using the default initializer of
their elements. Therefore only check if a default
initializer is available when the result is scalar. */
- init_exp = rsym->as ? NULL
+ init_exp = rsym->as ? NULL
: gfc_generate_initializer (&rsym->ts, true);
if (init_exp)
{
@@ -7000,8 +7743,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)
{
@@ -7015,8 +7756,8 @@ gfc_generate_function_code (gfc_namespace * ns)
/* Finish the function body and add init and cleanup code. */
tmp = gfc_finish_block (&body);
- gfc_start_wrapped_block (&try_block, tmp);
/* Add code to create and cleanup arrays. */
+ gfc_start_wrapped_block (&try_block, tmp);
gfc_trans_deferred_vars (sym, &try_block);
gfc_add_init_cleanup (&try_block, gfc_finish_block (&init),
gfc_finish_block (&cleanup));
@@ -7034,7 +7775,8 @@ gfc_generate_function_code (gfc_namespace * ns)
}
saved_function_decls = NULL_TREE;
- DECL_SAVED_TREE (fndecl) = gfc_finish_wrapped_block (&try_block);
+ gfc_add_expr_to_block (&outer_block, gfc_finish_wrapped_block (&try_block));
+ DECL_SAVED_TREE (fndecl) = gfc_finish_block (&outer_block);
decl = getdecls ();
/* Finish off this function and send it for code generation. */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index afca3a678cf..01389373065 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2866,6 +2866,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)
@@ -4922,7 +4925,7 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr, int g77,
if (fsym && proc_name)
msg = xasprintf ("An array temporary was created for argument "
- "'%s' of procedure '%s'", fsym->name, proc_name);
+ "'%s' of procedure '%s'", fsym->name, proc_name);
else
msg = xasprintf ("An array temporary was created");
@@ -5220,6 +5223,8 @@ class_array_fcn:
tree post_cond;
type = TREE_TYPE (parmse->expr);
+ if (POINTER_TYPE_P (type) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
+ type = TREE_TYPE (type);
pointer = gfc_create_var (type, "arg_ptr");
if (check_contiguous)
@@ -5263,17 +5268,25 @@ class_array_fcn:
gfc_add_block_to_block (&se->pre, &(&array_se)->pre);
gfc_add_block_to_block (&se->pre, &(&array_se)->post);
- /* if_stmt = { pointer = &a[0]; } . */
+ /* if_stmt = { descriptor ? pointer = a : pointer = &a[0]; } . */
gfc_init_block (&if_block);
- tmp = gfc_conv_array_data (array_se.expr);
- tmp = fold_convert (type, tmp);
- gfc_add_modify (&if_block, pointer, tmp);
+ if (GFC_DESCRIPTOR_TYPE_P (type))
+ gfc_add_modify (&if_block, pointer, array_se.expr);
+ else
+ {
+ tmp = gfc_conv_array_data (array_se.expr);
+ tmp = fold_convert (type, tmp);
+ gfc_add_modify (&if_block, pointer, tmp);
+ }
if_stmt = gfc_finish_block (&if_block);
/* else_stmt = { parmse->pre(); pointer = parmse->expr; } . */
gfc_init_block (&else_block);
gfc_add_block_to_block (&else_block, &parmse->pre);
- gfc_add_modify (&else_block, pointer, parmse->expr);
+ tmp = (GFC_DESCRIPTOR_TYPE_P (type)
+ ? build_fold_indirect_ref_loc (input_location, parmse->expr)
+ : parmse->expr);
+ gfc_add_modify (&else_block, pointer, tmp);
else_stmt = gfc_finish_block (&else_block);
/* And put the above into an if statement. */
@@ -5300,7 +5313,11 @@ class_array_fcn:
/* else_stmt = { pointer = NULL; } . */
gfc_init_block (&else_block);
- gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
+ if (GFC_DESCRIPTOR_TYPE_P (type))
+ gfc_conv_descriptor_data_set (&else_block, pointer,
+ null_pointer_node);
+ else
+ gfc_add_modify (&else_block, pointer, build_int_cst (type, 0));
else_stmt = gfc_finish_block (&else_block);
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
@@ -5344,6 +5361,24 @@ class_array_fcn:
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, post_cond,
post_stmts, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
+ if (GFC_DESCRIPTOR_TYPE_P (type))
+ {
+ type = TREE_TYPE (parmse->expr);
+ if (POINTER_TYPE_P (type))
+ {
+ pointer = gfc_build_addr_expr (type, pointer);
+ if (pass_optional)
+ {
+ tmp = gfc_likely (present_var, PRED_FORTRAN_ABSENT_DUMMY);
+ pointer = fold_build3_loc (input_location, COND_EXPR, type,
+ tmp, pointer,
+ fold_convert (type,
+ null_pointer_node));
+ }
+ }
+ else
+ gcc_assert (!pass_optional);
+ }
se->expr = pointer;
}
@@ -5484,168 +5519,457 @@ 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, tmp, tmp2;
+ tree present = NULL;
+ tree gfc_strlen = 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);
+
+ gfc_init_block (&block);
- /* 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))
+ /* 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;
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, e);
+ gfc = se.expr;
+ /* gfc_conv_constant ignores se.want_poiner, e.g. for string_cst. */
+ if (!POINTER_TYPE_P (TREE_TYPE (gfc)))
+ gfc = gfc_build_addr_expr (NULL, gfc);
+ }
+ else
+ {
+ /* If the actual argument can be noncontiguous, copy-in/out is required,
+ if the dummy has either the CONTIGUOUS attribute or is an assumed-
+ length assumed-length/assumed-size CHARACTER array. */
+ se.force_no_tmp = 1;
+ if ((fsym->attr.contiguous
+ || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
+ && (fsym->as->type == AS_ASSUMED_SIZE
+ || fsym->as->type == AS_EXPLICIT)))
+ && !gfc_is_simply_contiguous (e, false, true))
+ {
+ bool optional = fsym->attr.optional;
+ fsym->attr.optional = 0;
+ gfc_conv_subref_array_arg (&se, e, false, fsym->attr.intent,
+ fsym->attr.pointer, fsym,
+ fsym->ns->proc_name->name, NULL,
+ /* check_contiguous= */ true);
+ fsym->attr.optional = optional;
+ }
+ else
+ 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);
+ }
+ if (e->ts.type == BT_CHARACTER)
+ {
+ if (se.string_length)
+ gfc_strlen = se.string_length;
+ else if (e->ts.u.cl->backend_decl)
+ gfc_strlen = e->ts.u.cl->backend_decl;
+ else
+ gcc_unreachable ();
}
+ 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");
+ /* Convert to CFI_cdesc_t, which has dim[] to avoid TBAA issues,*/
+ if (fsym->attr.dimension && fsym->as->type == AS_ASSUMED_RANK)
+ {
+ tmp = gfc_get_cfi_type (-1, !fsym->attr.pointer && !fsym->attr.target);
+ tmp = build_pointer_type (tmp);
+ parmse->expr = cfi = gfc_build_addr_expr (tmp, cfi);
+ cfi = build_fold_indirect_ref_loc (input_location, cfi);
+ }
+ else
+ parmse->expr = gfc_build_addr_expr (NULL, 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:
+ itype = CFI_type_from_type_kind (e->ts.type, e->ts.kind);
+ break;
+ case BT_CHARACTER:
+ itype = CFI_type_from_type_kind (CFI_type_Character, 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)
- cfi_attribute = 0;
+ attr = CFI_attribute_pointer;
else if (fsym->attr.allocatable)
- cfi_attribute = 1;
- else
- cfi_attribute = 2;
+ 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)
+ if (e->rank == 0)
{
- parmse->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,
- 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);
- }
+ 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);
+ /* Set elem_len if known - must be before the next if block.
+ Note that allocatable implies 'len=:'. */
+ if (e->ts.type != BT_ASSUMED && e->ts.type != BT_CHARACTER )
+ {
+ /* 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));
}
- /* 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);
+ /* 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;
+ }
- /* Now pass the gfc_descriptor by reference. */
- parmse->expr = gfc_build_addr_expr (NULL_TREE, parmse->expr);
+ /* If not unallocated/unassociated. */
+ gfc_init_block (&block2);
- /* 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);
+ /* Set elem_len, which may be only known at run time. */
+ 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)
+ {
+ 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));
+ }
- /* 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->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_Character + 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_Complex + kind/2 else < tmp2 > */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, type,
+ build_int_cst (TREE_TYPE (type), BT_COMPLEX));
+ 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);
+ }
- /* 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);
+ if (e->rank != 0)
+ {
+ /* Loop: for (i = 0; i < rank; ++i). */
+ tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
+ /* Loop body. */
+ stmtblock_t loop_body;
+ gfc_init_block (&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 (&loop_body, 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 (&loop_body, 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 (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
- /* The CFI descriptor is passed to the bind_C procedure. */
- parmse->expr = cfi_desc_ptr;
+ /* Generate loop. */
+ gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
+ rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+ gfc_finish_block (&loop_body));
- /* Free the CFI descriptor. */
- tmp = gfc_call_free (cfi_desc_ptr);
- gfc_prepend_expr_to_block (&parmse->post, tmp);
+ 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));
+ }
+ }
- /* 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:
+ 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);
+
+ if (fsym->attr.allocatable)
+ {
+ /* gfc->span = cfi->elem_len. */
+ tmp = fold_convert (gfc_array_index_type,
+ gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
+ }
+ else
+ {
+ /* gfc->span = ((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]);
+ tmp2 = fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi));
+ tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+ gfc_array_index_type, tmp, tmp2);
+ 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]), tmp2);
+ }
+ 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 idx = gfc_create_var (TREE_TYPE (rank), "idx");
+ /* Loop body. */
+ stmtblock_t loop_body;
+ gfc_init_block (&loop_body);
+ /* gfc->dim[i].lbound = ... */
+ tmp = gfc_get_cfi_dim_lbound (cfi, idx);
+ gfc_conv_descriptor_lbound_set (&loop_body, 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 (&loop_body, 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 (&loop_body, 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 (&loop_body, gfc, tmp);
+ /* Generate loop. */
+ gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 0),
+ rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+ gfc_finish_block (&loop_body));
+ }
+
+ 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);
}
@@ -5764,17 +6088,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,
@@ -6005,9 +6324,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);
@@ -6217,7 +6534,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;
@@ -6474,8 +6792,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
ref->u.ar.type = AR_SECTION;
}
- 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);
@@ -6535,9 +6852,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
sym->name, NULL);
/* 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)
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 37d23310e3e..4f1b3462959 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -72,7 +72,8 @@ gfc_omp_is_allocatable_or_ptr (const_tree decl)
static bool
gfc_omp_is_optional_argument (const_tree decl)
{
- return (TREE_CODE (decl) == PARM_DECL
+ /* Note: VAR_DECL can occur with BIND(C) and array descriptors. */
+ return ((TREE_CODE (decl) == PARM_DECL || TREE_CODE (decl) == VAR_DECL)
&& DECL_LANG_SPECIFIC (decl)
&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
&& !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
@@ -105,8 +106,9 @@ gfc_omp_check_optional_argument (tree decl, bool for_present_check)
|| GFC_ARRAY_TYPE_P (TREE_TYPE (decl))))
decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+ /* Note: With BIND(C), array descriptors are converted to a VAR_DECL. */
if (decl == NULL_TREE
- || TREE_CODE (decl) != PARM_DECL
+ || (TREE_CODE (decl) != PARM_DECL && TREE_CODE (decl) != VAR_DECL)
|| !DECL_LANG_SPECIFIC (decl)
|| !GFC_DECL_OPTIONAL_ARGUMENT (decl))
return NULL_TREE;
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index a8ff473510f..c66a3bee83e 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -3670,10 +3670,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;
@@ -3687,24 +3684,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:
@@ -3748,8 +3746,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));
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 220976babb8..50fceebc941 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -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 = */ false);
+ else if (sym->attr.dimension || sym->attr.codimension)
{
if (gfc_is_nodesc_array (sym))
{
@@ -3132,7 +3138,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
@@ -3723,4 +3729,95 @@ 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 = gfc_rank_cst[dimen - 1];
+ range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+ range);
+ 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);
+ }
+
+ TYPE_TYPELESS_STORAGE (CFI_cdesc_t) = 1;
+ gfc_finish_type (CFI_cdesc_t);
+ gfc_cfi_descriptor_base[idx] = CFI_cdesc_t;
+ return CFI_cdesc_t;
+}
+
#include "gt-fortran-trans-types.h"
diff --git a/gcc/fortran/trans-types.h b/gcc/fortran/trans-types.h
index 6804bfe9edb..15d206b9443 100644
--- a/gcc/fortran/trans-types.h
+++ b/gcc/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);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index eb5682a7cda..22f267645e8 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -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,
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index fa3e8651b44..7ec4ca53a2c 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -857,8 +857,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;
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_19.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_19.f90
new file mode 100644
index 00000000000..8cc1601d047
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_19.f90
@@ -0,0 +1,28 @@
+! { dg-do run }
+! This testcase failed before with optimization as
+! allocatef's CFI descriptor argument 'x' failed with -fstrict-alias due to
+! internally alising with the GFC descriptor
+!
+
+program testit
+ use iso_c_binding
+ implicit none (external, type)
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+ type(m), allocatable :: a(:)
+
+ call testf (a)
+
+contains
+ subroutine allocatef (x) bind (c)
+ type(m), allocatable :: x(:)
+ allocate (x(5:15))
+ end subroutine
+
+ subroutine testf (y)
+ type(m), allocatable, target :: y(:)
+ call allocatef (y)
+ if (.not. allocated (y)) stop 1
+ end subroutine
+end program
diff --git a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90 b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90
index 7731d1a6c88..c596e47cfdd 100644
--- a/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90
+++ b/gcc/testsuite/gfortran.dg/ISO_Fortran_binding_4.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/PR100914.f90 b/gcc/testsuite/gfortran.dg/PR100914.f90
index d8057fd617c..8588157e59c 100644
--- a/gcc/testsuite/gfortran.dg/PR100914.f90
+++ b/gcc/testsuite/gfortran.dg/PR100914.f90
@@ -1,5 +1,5 @@
! Fails on x86 targets where sizeof(long double) == 16.
-! { dg-do run { xfail { { x86_64*-*-* i?86*-*-* } && longdouble128 } } }
+! { dg-do run }
! { dg-additional-sources PR100914.c }
! { dg-require-effective-target fortran_real_c_float128 }
! { dg-additional-options "-Wno-pedantic" }
diff --git a/gcc/testsuite/gfortran.dg/PR100915.c b/gcc/testsuite/gfortran.dg/PR100915.c
index 5b219b37187..4eaf82a5d27 100644
--- a/gcc/testsuite/gfortran.dg/PR100915.c
+++ b/gcc/testsuite/gfortran.dg/PR100915.c
@@ -67,7 +67,7 @@ check_fn (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed
/* */
assert (auxp->type==type);
ityp = _CFI_decode_type(auxp->type);
- assert (ityp == CFI_type_cptr);
+ assert (ityp == CFI_type_cfunptr);
iknd = _CFI_decode_kind(auxp->type);
assert (_CFI_decode_type(type)==ityp);
assert (kind==iknd);
diff --git a/gcc/testsuite/gfortran.dg/PR100915.f90 b/gcc/testsuite/gfortran.dg/PR100915.f90
index 083565e5ddf..64a2a88fe2d 100644
--- a/gcc/testsuite/gfortran.dg/PR100915.f90
+++ b/gcc/testsuite/gfortran.dg/PR100915.f90
@@ -14,7 +14,7 @@ module isof_m
private
public :: &
- CFI_type_cptr
+ CFI_type_cptr, CFI_type_cfunptr
public :: &
check_fn_as, &
@@ -33,6 +33,7 @@ module isof_m
! Intrinsic types. Their kind number defines their storage size. */
integer(kind=c_signed_char), parameter :: CFI_type_cptr = 7
+ integer(kind=c_signed_char), parameter :: CFI_type_cfunptr = 8
interface
subroutine check_fn_as(a, t, k, e, n) &
@@ -99,7 +100,7 @@ module iso_check_m
c_funptr, c_funloc, c_associated
use :: isof_m, only: &
- CFI_type_cptr
+ CFI_type_cptr, CFI_type_cfunptr
use :: isof_m, only: &
check_fn_as, &
@@ -155,7 +156,7 @@ contains
!
k = 0
e = storage_size(a)/b
- t = cfi_encode_type(CFI_type_cptr, k)
+ t = cfi_encode_type(CFI_type_cfunptr, k)
! Assumes 64-bit target.
! if(e/=8) stop 5
do i = 1, n
@@ -176,7 +177,7 @@ contains
!
k = 0
e = storage_size(a)/b
- t = cfi_encode_type(CFI_type_cptr, k)
+ t = cfi_encode_type(CFI_type_cfunptr, k)
! Assumes 64-bit target.
! if(e/=8) stop 8
do i = 1, n
@@ -198,7 +199,7 @@ contains
!
k = 0
e = storage_size(a)/b
- t = cfi_encode_type(CFI_type_cptr, k)
+ t = cfi_encode_type(CFI_type_cfunptr, k)
! Assumes 64-bit target.
! if(e/=8) stop 11
select rank(a)
@@ -229,7 +230,7 @@ contains
!
k = 0
e = storage_size(a)/b
- t = cfi_encode_type(CFI_type_cptr, k)
+ t = cfi_encode_type(CFI_type_cfunptr, k)
! Assumes 64-bit target.
! if(e/=8) stop 16
select rank(a)
diff --git a/gcc/testsuite/gfortran.dg/PR93963.f90 b/gcc/testsuite/gfortran.dg/PR93963.f90
index 4e1b06fd525..66c937974ac 100644
--- a/gcc/testsuite/gfortran.dg/PR93963.f90
+++ b/gcc/testsuite/gfortran.dg/PR93963.f90
@@ -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
@@ -97,27 +99,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 +174,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
diff --git a/gcc/testsuite/gfortran.dg/assumed_type_12.f90 b/gcc/testsuite/gfortran.dg/assumed_type_12.f90
new file mode 100644
index 00000000000..ce6d0bc5a93
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_type_12.f90
@@ -0,0 +1,34 @@
+! 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. corresponding to assumed-rank dummy argument 'b' must be assumed-shape or assumed-rank" }
+ call ar(y) ! { dg-error "Assumed-type actual argument at .1. corresponding to assumed-rank dummy argument 'b' must be assumed-shape or 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
diff --git a/gcc/testsuite/gfortran.dg/assumed_type_13.c b/gcc/testsuite/gfortran.dg/assumed_type_13.c
new file mode 100644
index 00000000000..d602d35b4a4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_type_13.c
@@ -0,0 +1,26 @@
+#include <ISO_Fortran_binding.h>
+
+void
+test_c (CFI_cdesc_t *x, size_t n, int num)
+{
+ if (!x->base_addr)
+ __builtin_abort ();
+ if (x->version != CFI_VERSION)
+ __builtin_abort ();
+ if (x->rank != 1)
+ __builtin_abort ();
+ if (x->attribute != CFI_attribute_other)
+ __builtin_abort ();
+ if (x->dim[0].lower_bound != 0)
+ __builtin_abort ();
+ if (x->dim[0].extent != 3)
+ __builtin_abort ();
+
+ if (x->elem_len != n || x->dim[0].sm != n)
+ __builtin_abort ();
+
+ if (num == 1 && x->type != CFI_type_int16_t)
+ __builtin_abort ();
+ if (num == 2 && x->type != CFI_type_double_Complex)
+ __builtin_abort ();
+}
diff --git a/gcc/testsuite/gfortran.dg/assumed_type_13.f90 b/gcc/testsuite/gfortran.dg/assumed_type_13.f90
new file mode 100644
index 00000000000..da167aee0fa
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_type_13.f90
@@ -0,0 +1,66 @@
+! { dg-do run }
+! { dg-additional-sources assumed_type_13.c }
+
+use iso_c_binding, only: c_size_t, c_int
+implicit none (type, external)
+
+interface
+ subroutine test_c (x, n, num) bind (C)
+ import :: c_size_t, c_int
+ integer(c_size_t), value :: n
+ integer(c_int), value :: num
+ type(*) :: x(:)
+ end subroutine test_c
+end interface
+
+complex(8) :: b(3)
+
+call test_c ([1_2, 2_2, 3_2], sizeof(1_2), num=1)
+call test_c (b, sizeof(b(1)), num=2)
+call outer_bc ([1_2, 2_2, 3_2], sizeof(1_2), num=1)
+call outer_bc (b, sizeof(b(1)), num=2)
+call outer_f ([1_2, 2_2, 3_2], sizeof(1_2), num=1)
+call outer_f (b, sizeof(b(1)), num=2)
+
+contains
+
+subroutine outer_bc (x, n, num) bind(C)
+ integer(c_size_t), value :: n
+ integer(c_int), value :: num
+ type(*) :: x(:)
+ ! print *,sizeof(x)/size(x), n
+ if (sizeof(x)/size(x) /= n) error stop 1
+ call inner_bc (x, n, num)
+ call inner_f (x, n, num)
+ call test_c (x, n, num)
+end
+
+subroutine outer_f (x, n, num)
+ integer(c_size_t), value :: n
+ integer(c_int), value :: num
+ type(*) :: x(:)
+ ! print *,sizeof(x)/size(x), n
+ if (sizeof(x)/size(x) /= n) error stop 1
+ call inner_f (x, n, num)
+ call inner_bc (x, n, num)
+ call test_c (x, n, num)
+end
+
+subroutine inner_bc(x, n, num) bind(C)
+ integer(c_size_t), value :: n
+ integer(c_int), value :: num
+ type(*) :: x(:)
+ ! print *,sizeof(x)/size(x), n
+ if (sizeof(x)/size(x) /= n) error stop 2
+ call test_c (x, n, num)
+end
+
+subroutine inner_f(x, n, num)
+ integer(c_size_t), value :: n
+ integer(c_int), value :: num
+ type(*) :: x(:)
+ ! print *,sizeof(x)/size(x), n
+ if (sizeof(x)/size(x) /= n) error stop 3
+ call test_c (x, n, num)
+end
+end
diff --git a/gcc/testsuite/gfortran.dg/bind-c-char-descr.f90 b/gcc/testsuite/gfortran.dg/bind-c-char-descr.f90
new file mode 100644
index 00000000000..3b01ad3b63d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bind-c-char-descr.f90
@@ -0,0 +1,104 @@
+! PR fortran/92482
+!
+! Contributed by José Rui Faustino de Sousa
+!
+! Note the xfail issue below for 'strg_print_2("abc")
+
+program strp_p
+
+ use, intrinsic :: iso_c_binding, only: &
+ c_char
+
+ implicit none
+
+ integer, parameter :: l = 3
+
+ character(len=l, kind=c_char), target :: str
+ character(len=:, kind=c_char), pointer :: strp_1
+ character(len=l, kind=c_char), pointer :: strp_2
+
+ str = "abc"
+ nullify(strp_1, strp_2)
+ strp_1 => str
+ strp_2 => str
+ if (len(str) /= 3 .or. str /= "abc") stop 1
+ if (len(strp_1) /= 3 .or. strp_1 /= "abc") stop 2
+ if (len(strp_2) /= 3 .or. strp_2 /= "abc") stop 3
+ call strg_print_0("abc") ! Error (10.0.0) or segmentation fault (9.1.0)
+ call strg_print_0(str) ! Error (10.0.0) or segmentation fault (9.1.0)
+ call strg_print_0(strp_1) ! Error (10.0.0) or segmentation fault (9.1.0)
+ call strg_print_0(strp_2) ! Error (10.0.0) or segmentation fault (9.1.0)
+ call strg_print_1(strp_1) ! Not yet supported
+
+ call strg_print_2("abc", xfail=.true.)
+ call strg_print_2(str)
+ call strg_print_2(strp_1)
+ call strg_print_2(strp_2)
+
+ call strg_print_2_c("abc")
+ call strg_print_2_c(str)
+ call strg_print_2_c(strp_1)
+ call strg_print_2_c(strp_2)
+
+contains
+
+ subroutine strg_print_0(this) bind(c) ! Error (10.0.0 20191106) or warning (9.1.0) issued with bind(c)
+ character(len=*, kind=c_char), target, intent(in) :: this
+
+ if (len (this) /= 3) stop 10
+ if (this /= "abc") stop 11
+ end subroutine strg_print_0
+
+ subroutine strg_print_1(this) bind(c) ! Not yet supported with bind(c)
+ character(len=:, kind=c_char), pointer, intent(in) :: this
+ character(len=:), pointer :: strn
+
+ if (.not. associated (this)) stop 20
+ if (len (this) /= 3) stop 21
+ if (this /= "abc") stop 22
+ strn => this
+ if (.not. associated (strn)) stop 23
+ if(associated(strn))then
+ if (len (this) /= 3) stop 24
+ if (this /= "abc") stop 25
+ end if
+ end subroutine strg_print_1
+
+ subroutine strg_print_2(this, xfail)
+ use, intrinsic :: iso_c_binding, only: &
+ c_loc, c_f_pointer
+
+ type(*), target, intent(in) :: this(..)
+ logical, optional, value :: xfail
+ character(len=l), pointer :: strn
+
+ call c_f_pointer(c_loc(this), strn)
+ if (.not. associated (strn)) stop 30
+ if(associated(strn))then
+ if (len (strn) /= 3) stop 31
+ if (strn /= "abc") then
+ if (present (xfail)) then
+ print *, 'INVALID STRING - EXPECTED "abc" / PR47225'
+ else
+ stop 32
+ end if
+ end if
+ end if
+ end subroutine strg_print_2
+
+ subroutine strg_print_2_c(this) bind(c)
+ use, intrinsic :: iso_c_binding, only: &
+ c_loc, c_f_pointer
+
+ type(*), target, intent(in) :: this(..)
+ character(len=l), pointer :: strn
+
+ call c_f_pointer(c_loc(this), strn)
+ if (.not. associated (strn)) stop 40
+ if(associated(strn))then
+ if (len (strn) /= 3) stop 41
+ if (strn /= "abc") stop 42
+ end if
+ end subroutine strg_print_2_c
+
+end program strp_p
diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-1.c b/gcc/testsuite/gfortran.dg/bind-c-contiguous-1.c
new file mode 100644
index 00000000000..06bbd6f261d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-1.c
@@ -0,0 +1,345 @@
+#include <ISO_Fortran_binding.h>
+#include <stdbool.h>
+#include <string.h>
+
+struct loc_t {
+ intptr_t x, y, z;
+};
+
+typedef struct loc_t (*ftn_fn) (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_size_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_size_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_expl_size_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_expl_size_in_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_rank_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_rank_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_rank_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_rank_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_shape_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_shape_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_shape_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_shape_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+
+static void
+basic_check(CFI_cdesc_t *x, bool is_cont)
+{
+ if (!x->base_addr)
+ __builtin_abort ();
+ if (x->elem_len != 3*sizeof(char))
+ __builtin_abort ();
+ if (x->version != CFI_VERSION)
+ __builtin_abort ();
+ if (x->rank != 1)
+ __builtin_abort ();
+ if (x->attribute != CFI_attribute_other)
+ __builtin_abort ();
+ if (x->type != CFI_type_char)
+ __builtin_abort ();
+ if (x->dim[0].lower_bound != 0)
+ __builtin_abort ();
+ if (x->dim[0].extent != 3)
+ __builtin_abort ();
+ if (CFI_is_contiguous (x) != (x->elem_len == x->dim[0].sm))
+ __builtin_abort ();
+ if (is_cont != CFI_is_contiguous (x))
+ __builtin_abort ();
+}
+
+static void
+print_str (void *p, size_t len)
+{
+ __builtin_printf ("DEBUG: >");
+ for (size_t i = 0; i < len; ++i)
+ __builtin_printf ("%c", ((const char*) p)[i]);
+ __builtin_printf ("<\n");
+}
+
+static void
+check_str (CFI_cdesc_t *x, const char *str, const CFI_index_t subscripts[])
+{
+ /* Avoid checking for '\0'. */
+ if (strncmp ((const char*) CFI_address (x, subscripts), str, strlen(str)) != 0)
+ __builtin_abort ();
+}
+
+static void
+set_str (CFI_cdesc_t *x, const char *str, const CFI_index_t subscripts[])
+{
+ char *p = CFI_address (x, subscripts);
+ size_t len = strlen (str);
+ if (x->elem_len != len)
+ __builtin_abort ();
+ for (size_t i = 0; i < len; ++i)
+ p[i] = str[i];
+}
+
+static struct loc_t
+do_call (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num, bool intent_in, ftn_fn fn, bool is_cont, bool fort_cont)
+{
+ const CFI_index_t zero[1] = { 0 };
+ const CFI_index_t one[1] = { 1 };
+ const CFI_index_t two[1] = { 2 };
+ struct loc_t addr1, addr2;
+ if (k != 3)
+ __builtin_abort ();
+ basic_check (x, is_cont || num == 2);
+ basic_check (y, is_cont || num == 2);
+ basic_check (z, is_cont || num == 2);
+ if (!is_cont && num == 1)
+ {
+ check_str (x, "abc", zero);
+ check_str (x, "ghi", one);
+ check_str (x, "nop", two);
+ check_str (y, "abc", zero);
+ check_str (y, "ghi", one);
+ check_str (y, "nop", two);
+ check_str (z, "abc", zero);
+ check_str (z, "ghi", one);
+ check_str (z, "nop", two);
+ }
+ else if (num == 1)
+ {
+ if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0)
+ __builtin_abort ();
+ }
+ else if (num == 2)
+ {
+ if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0)
+ __builtin_abort ();
+ }
+ else
+ __builtin_abort ();
+ addr1.x = (intptr_t) x->base_addr;
+ addr1.y = (intptr_t) y->base_addr;
+ addr1.z = (intptr_t) z->base_addr;
+ addr2 = fn (x, y, z, 3, num);
+ if (!CFI_is_contiguous (x) && fort_cont)
+ {
+ /* Check for callee copy in/copy out. */
+ if (addr1.x == addr2.x || addr1.x != (intptr_t) x->base_addr)
+ __builtin_abort ();
+ if (addr1.y == addr2.y || addr1.y != (intptr_t) y->base_addr)
+ __builtin_abort ();
+ if (addr1.z == addr2.z || addr1.z != (intptr_t) z->base_addr)
+ __builtin_abort ();
+ }
+ else
+ {
+ if (addr1.x != addr2.x || addr1.x != (intptr_t) x->base_addr)
+ __builtin_abort ();
+ if (addr1.y != addr2.y || addr1.y != (intptr_t) y->base_addr)
+ __builtin_abort ();
+ if (addr1.z != addr2.z || addr1.z != (intptr_t) z->base_addr)
+ __builtin_abort ();
+ }
+ // intent_in
+ if (intent_in && !is_cont && num == 1)
+ {
+ check_str (x, "abc", zero);
+ check_str (x, "ghi", one);
+ check_str (x, "nop", two);
+ check_str (y, "abc", zero);
+ check_str (y, "ghi", one);
+ check_str (y, "nop", two);
+ check_str (z, "abc", zero);
+ check_str (z, "ghi", one);
+ check_str (z, "nop", two);
+ }
+ else if (intent_in && num == 1)
+ {
+ if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0)
+ __builtin_abort ();
+ }
+ else if (intent_in && num == 2)
+ {
+ if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0)
+ __builtin_abort ();
+ }
+ else if (intent_in)
+ __builtin_abort ();
+ if (intent_in)
+ {
+ if (is_cont && num == 1)
+ {
+ /* Copy in - set the value to check that no copy out is done. */
+ memcpy ((char*) x->base_addr, "123456789", 9);
+ memcpy ((char*) y->base_addr, "123456789", 9);
+ memcpy ((char*) z->base_addr, "123456789", 9);
+ }
+ return addr1;
+ }
+ // !intent_in
+ if (!is_cont && num == 1)
+ {
+ check_str (x, "ABC", zero);
+ check_str (x, "DEF", one);
+ check_str (x, "GHI", two);
+ check_str (y, "ABC", zero);
+ check_str (y, "DEF", one);
+ check_str (y, "GHI", two);
+ check_str (z, "ABC", zero);
+ check_str (z, "DEF", one);
+ check_str (z, "GHI", two);
+ }
+ else
+ {
+ if (strncmp ((const char*) x->base_addr, "ABCDEFGHI", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) y->base_addr, "ABCDEFGHI", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) z->base_addr, "ABCDEFGHI", 9) != 0)
+ __builtin_abort ();
+ }
+ return addr1;
+}
+
+struct loc_t
+char_assumed_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_assumed_size_f, true, false);
+}
+
+struct loc_t
+char_assumed_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_size_in_f, true, false);
+}
+
+struct loc_t
+char_expl_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_expl_size_f, true, false);
+}
+
+struct loc_t
+char_expl_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_expl_size_in_f, true, false);
+}
+
+struct loc_t
+char_assumed_rank_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_assumed_rank_f, false, false);
+}
+
+struct loc_t
+char_assumed_rank_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_rank_in_f, false, false);
+}
+
+struct loc_t
+char_assumed_rank_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, true, false);
+}
+
+struct loc_t
+char_assumed_rank_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, true, false);
+}
+
+static void
+reset_var (CFI_cdesc_t *x, int num)
+{
+ const CFI_index_t zero[1] = { 0 };
+ const CFI_index_t one[1] = { 1 };
+ const CFI_index_t two[1] = { 2 };
+
+ if (num == 1)
+ {
+ set_str (x, "abc", zero);
+ set_str (x, "ghi", one);
+ set_str (x, "nop", two);
+ }
+ else if (num == 2)
+ {
+ set_str (x, "def", zero);
+ set_str (x, "ghi", one);
+ set_str (x, "jlm", two);
+ }
+ else
+ __builtin_abort ();
+}
+
+static void
+reset_vars (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, int num)
+{
+ reset_var (x, num);
+ reset_var (y, num);
+ reset_var (z, num);
+}
+
+struct loc_t
+char_assumed_shape_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ /* Make use of having a noncontiguous argument to check that the callee
+ handles noncontiguous variables. */
+ do_call (x, y, z, k, num, false, char_assumed_size_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, true, char_assumed_size_in_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, false, char_expl_size_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, true, char_expl_size_in_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, false, true);
+ /* Actual func call. */
+ reset_vars (x, y, z, num);
+ return do_call (x, y, z, k, num, false, char_assumed_shape_f, false, false);
+}
+
+struct loc_t
+char_assumed_shape_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_shape_in_f, false, false);
+}
+
+struct loc_t
+char_assumed_shape_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, true, false);
+}
+
+struct loc_t
+char_assumed_shape_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, true, false);
+}
diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-1.f90 b/gcc/testsuite/gfortran.dg/bind-c-contiguous-1.f90
new file mode 100644
index 00000000000..77dd3a251d2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-1.f90
@@ -0,0 +1,1574 @@
+! { dg-do run }
+! { dg-additional-sources bind-c-contiguous-1.c }
+! { dg-additional-options "-fcheck=all" }
+! { dg-prune-output "command-line option '-fcheck=.*' is valid for Fortran but not for C" }
+
+! Fortran demands that with bind(C), the callee ensure that for
+! * 'contiguous'
+! * len=* with explicit/assumed-size arrays
+! noncontiguous actual arguments are handled.
+! (in without bind(C) in gfortran, caller handles the copy in/out
+
+! Additionally, for a bind(C) callee, a Fortran-written caller
+! has to ensure the same (for contiguous + len=* to explicit-/assumed-size arrays)
+
+module m
+ use iso_c_binding, only: c_intptr_t, c_bool, c_loc, c_int
+ implicit none (type, external)
+
+ type, bind(C) :: loc_t
+ integer(c_intptr_t) :: x, y, z
+ end type loc_t
+
+interface
+ type(loc_t) function char_assumed_size_c (xx, yy, zz, n, num) bind(C)
+ import :: loc_t, c_bool, c_int
+ integer(c_int), value :: n, num
+ character(len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
+ end function
+
+ type(loc_t) function char_assumed_size_in_c (xx, yy, zz, n, num) bind(C)
+ import :: loc_t, c_bool, c_int
+ integer(c_int), value :: n, num
+ character(len=*), intent(in) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
+ end function
+
+ type(loc_t) function char_expl_size_c (xx, yy, zz, n, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer(c_int), value :: n, num
+ character(len=*) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3)
+ end function
+
+ type(loc_t) function char_expl_size_in_c (xx, yy, zz, n, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer(c_int), value :: n, num
+ character(len=*), intent(in) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3)
+ end function
+
+ type(loc_t) function char_assumed_rank_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*) :: xx(..)
+ character(len=3) :: yy(..)
+ character(len=k) :: zz(..)
+ end function
+
+ type(loc_t) function char_assumed_rank_in_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*), intent(in) :: xx(..)
+ character(len=3), intent(in) :: yy(..)
+ character(len=k), intent(in) :: zz(..)
+ end function
+
+ type(loc_t) function char_assumed_rank_cont_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*), contiguous :: xx(..)
+ character(len=3), contiguous :: yy(..)
+ character(len=k), contiguous :: zz(..)
+ end function
+
+ type(loc_t) function char_assumed_rank_cont_in_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*), contiguous, intent(in) :: xx(..)
+ character(len=3), contiguous, intent(in) :: yy(..)
+ character(len=k), contiguous, intent(in) :: zz(..)
+ end function
+
+ type(loc_t) function char_assumed_shape_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*) :: xx(:)
+ character(len=3) :: yy(5:)
+ character(len=k) :: zz(-k:)
+ end function
+
+ type(loc_t) function char_assumed_shape_in_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*), intent(in) :: xx(:)
+ character(len=3), intent(in) :: yy(5:)
+ character(len=k), intent(in) :: zz(-k:)
+ end function
+
+ type(loc_t) function char_assumed_shape_cont_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*), contiguous :: xx(:)
+ character(len=3), contiguous :: yy(5:)
+ character(len=k), contiguous :: zz(-k:)
+ end function
+
+ type(loc_t) function char_assumed_shape_cont_in_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*), contiguous, intent(in) :: xx(:)
+ character(len=3), contiguous, intent(in) :: yy(5:)
+ character(len=k), contiguous, intent(in) :: zz(-k:)
+ end function
+end interface
+
+contains
+
+type(loc_t) function char_assumed_size_f (xx, yy, zz, n, num) bind(c) result(res)
+ integer, value :: num, n
+ character(len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 1
+ if (3 /= len(yy)) error stop 1
+ if (3 /= len(zz)) error stop 1
+ if (1 /= lbound(xx,dim=1)) error stop 1
+ if (3 /= lbound(yy,dim=1)) error stop 1
+ if (6 /= lbound(zz,dim=1)) error stop 1
+ if (3 /= lbound(zz,dim=2)) error stop 1
+ if (3 /= lbound(zz,dim=3)) error stop 1
+ if (1 /= size(zz,dim=1)) error stop 1
+ if (1 /= size(zz,dim=2)) error stop 1
+ if (6 /= ubound(zz,dim=1)) error stop 1
+ if (3 /= ubound(zz,dim=2)) error stop 1
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "nop") error stop 4
+ if (yy(3) /= "abc") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "nop") error stop 4
+ if (zz(6,n,3) /= "abc") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "nop") error stop 4
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "jlm") error stop 4
+ if (yy(3) /= "def") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "jlm") error stop 4
+ if (zz(6,n,3) /= "def") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "jlm") error stop 4
+ else
+ error stop 8
+ endif
+ xx(1) = "ABC"
+ xx(2) = "DEF"
+ xx(3) = "GHI"
+ yy(3) = "ABC"
+ yy(4) = "DEF"
+ yy(5) = "GHI"
+ zz(6,n,3) = "ABC"
+ zz(6,n,4) = "DEF"
+ zz(6,n,5) = "GHI"
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+type(loc_t) function char_assumed_size_in_f (xx, yy, zz, n, num) bind(c) result(res)
+ integer, value :: num, n
+ character(len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
+ intent(in) :: xx, yy, zz
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 1
+ if (3 /= len(yy)) error stop 1
+ if (3 /= len(zz)) error stop 1
+ if (1 /= lbound(xx,dim=1)) error stop 1
+ if (3 /= lbound(yy,dim=1)) error stop 1
+ if (6 /= lbound(zz,dim=1)) error stop 1
+ if (3 /= lbound(zz,dim=2)) error stop 1
+ if (3 /= lbound(zz,dim=3)) error stop 1
+ if (1 /= size(zz,dim=1)) error stop 1
+ if (1 /= size(zz,dim=2)) error stop 1
+ if (6 /= ubound(zz,dim=1)) error stop 1
+ if (3 /= ubound(zz,dim=2)) error stop 1
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "nop") error stop 4
+ if (yy(3) /= "abc") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "nop") error stop 4
+ if (zz(6,n,3) /= "abc") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "nop") error stop 4
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "jlm") error stop 4
+ if (yy(3) /= "def") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "jlm") error stop 4
+ if (zz(6,n,3) /= "def") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "jlm") error stop 4
+ else
+ error stop 8
+ endif
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" } if (num == 1) then
+end
+
+type(loc_t) function char_expl_size_f (xx, yy, zz, n, num) bind(c) result(res)
+ integer, value :: num, n
+ character(len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2)
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 1
+ if (3 /= len(yy)) error stop 1
+ if (3 /= len(zz)) error stop 1
+ if (1 /= lbound(xx,dim=1)) error stop 1
+ if (3 /= lbound(yy,dim=1)) error stop 1
+ if (6 /= lbound(zz,dim=1)) error stop 1
+ if (3 /= lbound(zz,dim=2)) error stop 1
+ if (3 /= lbound(zz,dim=3)) error stop 1
+ if (3 /= size(xx,dim=1)) error stop 1
+ if (3 /= size(yy,dim=1)) error stop 1
+ if (1 /= size(zz,dim=1)) error stop 1
+ if (1 /= size(zz,dim=2)) error stop 1
+ if (3 /= size(zz,dim=3)) error stop 1
+ if (3 /= ubound(xx,dim=1)) error stop 1
+ if (5 /= ubound(yy,dim=1)) error stop 1
+ if (6 /= ubound(zz,dim=1)) error stop 1
+ if (3 /= ubound(zz,dim=2)) error stop 1
+ if (5 /= ubound(zz,dim=3)) error stop 1
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "nop") error stop 4
+ if (yy(3) /= "abc") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "nop") error stop 4
+ if (zz(6,n,3) /= "abc") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "nop") error stop 4
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "jlm") error stop 4
+ if (yy(3) /= "def") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "jlm") error stop 4
+ if (zz(6,n,3) /= "def") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "jlm") error stop 4
+ else
+ error stop 8
+ endif
+ xx(1) = "ABC"
+ xx(2) = "DEF"
+ xx(3) = "GHI"
+ yy(3) = "ABC"
+ yy(4) = "DEF"
+ yy(5) = "GHI"
+ zz(6,n,3) = "ABC"
+ zz(6,n,4) = "DEF"
+ zz(6,n,5) = "GHI"
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+type(loc_t) function char_expl_size_in_f (xx, yy, zz, n, num) bind(c) result(res)
+ integer, value :: num, n
+ character(len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2)
+ intent(in) :: xx, yy, zz
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 1
+ if (3 /= len(yy)) error stop 1
+ if (3 /= len(zz)) error stop 1
+ if (1 /= lbound(xx,dim=1)) error stop 1
+ if (3 /= lbound(yy,dim=1)) error stop 1
+ if (6 /= lbound(zz,dim=1)) error stop 1
+ if (3 /= lbound(zz,dim=2)) error stop 1
+ if (3 /= lbound(zz,dim=3)) error stop 1
+ if (3 /= size(xx,dim=1)) error stop 1
+ if (3 /= size(yy,dim=1)) error stop 1
+ if (1 /= size(zz,dim=1)) error stop 1
+ if (1 /= size(zz,dim=2)) error stop 1
+ if (3 /= size(zz,dim=3)) error stop 1
+ if (3 /= ubound(xx,dim=1)) error stop 1
+ if (5 /= ubound(yy,dim=1)) error stop 1
+ if (6 /= ubound(zz,dim=1)) error stop 1
+ if (3 /= ubound(zz,dim=2)) error stop 1
+ if (5 /= ubound(zz,dim=3)) error stop 1
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "nop") error stop 4
+ if (yy(3) /= "abc") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "nop") error stop 4
+ if (zz(6,n,3) /= "abc") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "nop") error stop 4
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "jlm") error stop 4
+ if (yy(3) /= "def") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "jlm") error stop 4
+ if (zz(6,n,3) /= "def") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "jlm") error stop 4
+ else
+ error stop 8
+ endif
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+
+type(loc_t) function char_assumed_rank_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*) :: xx(..)
+ character(len=3) :: yy(..)
+ character(len=k) :: zz(..)
+ if (3 /= len(xx)) error stop 40
+ if (3 /= len(yy)) error stop 40
+ if (3 /= len(zz)) error stop 40
+ if (3 /= size(xx)) error stop 41
+ if (3 /= size(yy)) error stop 41
+ if (3 /= size(zz)) error stop 41
+ if (1 /= rank(xx)) error stop 49
+ if (1 /= rank(yy)) error stop 49
+ if (1 /= rank(zz)) error stop 49
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (1 /= lbound(yy, dim=1)) stop 49
+ if (1 /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (3 /= ubound(yy, dim=1)) stop 49
+ if (3 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (is_contiguous (xx)) error stop 49
+ if (is_contiguous (yy)) error stop 49
+ if (is_contiguous (zz)) error stop 49
+ else if (num == 2) then
+ if (.not. is_contiguous (xx)) error stop 49
+ if (.not. is_contiguous (yy)) error stop 49
+ if (.not. is_contiguous (zz)) error stop 49
+ else
+ error stop 48
+ end if
+ select rank (xx)
+ rank (1)
+ print *, xx(1:3)
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 42
+ if (xx(2) /= "ghi") error stop 43
+ if (xx(3) /= "nop") error stop 44
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 45
+ if (xx(2) /= "ghi") error stop 46
+ if (xx(3) /= "jlm") error stop 47
+ else
+ error stop 48
+ endif
+ xx(1) = "ABC"
+ xx(2) = "DEF"
+ xx(3) = "GHI"
+ res%x = get_loc (xx)
+ rank default
+ error stop 99
+ end select
+ select rank (yy)
+ rank (1)
+ print *, yy(1:3)
+ if (num == 1) then
+ if (yy(1) /= "abc") error stop 42
+ if (yy(2) /= "ghi") error stop 43
+ if (yy(3) /= "nop") error stop 44
+ else if (num == 2) then
+ if (yy(1) /= "def") error stop 45
+ if (yy(2) /= "ghi") error stop 46
+ if (yy(3) /= "jlm") error stop 47
+ else
+ error stop 48
+ endif
+ yy(1) = "ABC"
+ yy(2) = "DEF"
+ yy(3) = "GHI"
+ res%y = get_loc (yy)
+ rank default
+ error stop 99
+ end select
+ select rank (zz)
+ rank (1)
+ print *, zz(1:3)
+ if (num == 1) then
+ if (zz(1) /= "abc") error stop 42
+ if (zz(2) /= "ghi") error stop 43
+ if (zz(3) /= "nop") error stop 44
+ else if (num == 2) then
+ if (zz(1) /= "def") error stop 45
+ if (zz(2) /= "ghi") error stop 46
+ if (zz(3) /= "jlm") error stop 47
+ else
+ error stop 48
+ endif
+ zz(1) = "ABC"
+ zz(2) = "DEF"
+ zz(3) = "GHI"
+ res%z = get_loc (zz)
+ rank default
+ error stop 99
+ end select
+contains
+ integer (c_intptr_t) function get_loc (arg)
+ character(len=*), target :: arg(:)
+ ! %loc does copy in/out if not simply contiguous
+ ! extra func needed because of 'target' attribute
+ get_loc = transfer (c_loc(arg), res%x)
+ end
+end
+
+type(loc_t) function char_assumed_rank_in_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*) :: xx(..)
+ character(len=3) :: yy(..)
+ character(len=k) :: zz(..)
+ intent(in) :: xx, yy, zz
+ if (3 /= size(yy)) error stop 50
+ if (3 /= len(yy)) error stop 51
+ if (1 /= rank(yy)) error stop 59
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (1 /= lbound(yy, dim=1)) stop 49
+ if (1 /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (3 /= ubound(yy, dim=1)) stop 49
+ if (3 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (is_contiguous (xx)) error stop 59
+ if (is_contiguous (yy)) error stop 59
+ if (is_contiguous (zz)) error stop 59
+ else if (num == 2) then
+ if (.not. is_contiguous (xx)) error stop 59
+ if (.not. is_contiguous (yy)) error stop 59
+ if (.not. is_contiguous (zz)) error stop 59
+ else
+ error stop 48
+ end if
+ select rank (xx)
+ rank (1)
+ print *, xx(1:3)
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 52
+ if (xx(2) /= "ghi") error stop 53
+ if (xx(3) /= "nop") error stop 54
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 55
+ if (xx(2) /= "ghi") error stop 56
+ if (xx(3) /= "jlm") error stop 57
+ else
+ error stop 58
+ endif
+ res%x = get_loc(xx)
+ rank default
+ error stop 99
+ end select
+ select rank (yy)
+ rank (1)
+ print *, yy(1:3)
+ if (num == 1) then
+ if (yy(1) /= "abc") error stop 52
+ if (yy(2) /= "ghi") error stop 53
+ if (yy(3) /= "nop") error stop 54
+ else if (num == 2) then
+ if (yy(1) /= "def") error stop 55
+ if (yy(2) /= "ghi") error stop 56
+ if (yy(3) /= "jlm") error stop 57
+ else
+ error stop 58
+ endif
+ res%y = get_loc(yy)
+ rank default
+ error stop 99
+ end select
+ select rank (zz)
+ rank (1)
+ print *, zz(1:3)
+ if (num == 1) then
+ if (zz(1) /= "abc") error stop 52
+ if (zz(2) /= "ghi") error stop 53
+ if (zz(3) /= "nop") error stop 54
+ else if (num == 2) then
+ if (zz(1) /= "def") error stop 55
+ if (zz(2) /= "ghi") error stop 56
+ if (zz(3) /= "jlm") error stop 57
+ else
+ error stop 58
+ endif
+ res%z = get_loc(zz)
+ rank default
+ error stop 99
+ end select
+contains
+ integer (c_intptr_t) function get_loc (arg)
+ character(len=*), target :: arg(:)
+ ! %loc does copy in/out if not simply contiguous
+ ! extra func needed because of 'target' attribute
+ get_loc = transfer (c_loc(arg), res%x)
+ end
+end
+
+
+
+type(loc_t) function char_assumed_rank_cont_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*) :: xx(..)
+ character(len=3) :: yy(..)
+ character(len=k) :: zz(..)
+ contiguous :: xx, yy, zz
+ if (3 /= len(xx)) error stop 60
+ if (3 /= len(yy)) error stop 60
+ if (3 /= len(zz)) error stop 60
+ if (3 /= size(xx)) error stop 61
+ if (3 /= size(yy)) error stop 61
+ if (3 /= size(zz)) error stop 61
+ if (1 /= rank(xx)) error stop 69
+ if (1 /= rank(yy)) error stop 69
+ if (1 /= rank(zz)) error stop 69
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (1 /= lbound(yy, dim=1)) stop 49
+ if (1 /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (3 /= ubound(yy, dim=1)) stop 49
+ if (3 /= ubound(zz, dim=1)) stop 49
+ select rank (xx)
+ rank (1)
+ print *, xx(1:3)
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 62
+ if (xx(2) /= "ghi") error stop 63
+ if (xx(3) /= "nop") error stop 64
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 65
+ if (xx(2) /= "ghi") error stop 66
+ if (xx(3) /= "jlm") error stop 67
+ else
+ error stop 68
+ endif
+ xx(1) = "ABC"
+ xx(2) = "DEF"
+ xx(3) = "GHI"
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+ select rank (yy)
+ rank (1)
+ print *, yy(1:3)
+ if (num == 1) then
+ if (yy(1) /= "abc") error stop 62
+ if (yy(2) /= "ghi") error stop 63
+ if (yy(3) /= "nop") error stop 64
+ else if (num == 2) then
+ if (yy(1) /= "def") error stop 65
+ if (yy(2) /= "ghi") error stop 66
+ if (yy(3) /= "jlm") error stop 67
+ else
+ error stop 68
+ endif
+ yy(1) = "ABC"
+ yy(2) = "DEF"
+ yy(3) = "GHI"
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+ select rank (zz)
+ rank (1)
+ print *, zz(1:3)
+ if (num == 1) then
+ if (zz(1) /= "abc") error stop 62
+ if (zz(2) /= "ghi") error stop 63
+ if (zz(3) /= "nop") error stop 64
+ else if (num == 2) then
+ if (zz(1) /= "def") error stop 65
+ if (zz(2) /= "ghi") error stop 66
+ if (zz(3) /= "jlm") error stop 67
+ else
+ error stop 68
+ endif
+ zz(1) = "ABC"
+ zz(2) = "DEF"
+ zz(3) = "GHI"
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+end
+
+type(loc_t) function char_assumed_rank_cont_in_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*) :: xx(..)
+ character(len=3) :: yy(..)
+ character(len=k) :: zz(..)
+ intent(in) :: xx, yy, zz
+ contiguous :: xx, yy, zz
+ if (3 /= size(xx)) error stop 30
+ if (3 /= size(yy)) error stop 30
+ if (3 /= size(zz)) error stop 30
+ if (3 /= len(xx)) error stop 31
+ if (3 /= len(yy)) error stop 31
+ if (3 /= len(zz)) error stop 31
+ if (1 /= rank(xx)) error stop 69
+ if (1 /= rank(yy)) error stop 69
+ if (1 /= rank(zz)) error stop 69
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (1 /= lbound(yy, dim=1)) stop 49
+ if (1 /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (3 /= ubound(yy, dim=1)) stop 49
+ if (3 /= ubound(zz, dim=1)) stop 49
+ select rank (xx)
+ rank (1)
+ print *, xx(1:3)
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 62
+ if (xx(2) /= "ghi") error stop 63
+ if (xx(3) /= "nop") error stop 64
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 65
+ if (xx(2) /= "ghi") error stop 66
+ if (xx(3) /= "jlm") error stop 67
+ else
+ error stop 68
+ endif
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+ select rank (yy)
+ rank (1)
+ print *, yy(1:3)
+ if (num == 1) then
+ if (yy(1) /= "abc") error stop 62
+ if (yy(2) /= "ghi") error stop 63
+ if (yy(3) /= "nop") error stop 64
+ else if (num == 2) then
+ if (yy(1) /= "def") error stop 65
+ if (yy(2) /= "ghi") error stop 66
+ if (yy(3) /= "jlm") error stop 67
+ else
+ error stop 68
+ endif
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+ select rank (zz)
+ rank (1)
+ print *, zz(1:3)
+ if (num == 1) then
+ if (zz(1) /= "abc") error stop 62
+ if (zz(2) /= "ghi") error stop 63
+ if (zz(3) /= "nop") error stop 64
+ else if (num == 2) then
+ if (zz(1) /= "def") error stop 65
+ if (zz(2) /= "ghi") error stop 66
+ if (zz(3) /= "jlm") error stop 67
+ else
+ error stop 68
+ endif
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+end
+
+type(loc_t) function char_assumed_shape_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*) :: xx(:)
+ character(len=3) :: yy(5:)
+ character(len=k) :: zz(-k:)
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 70
+ if (3 /= len(yy)) error stop 70
+ if (3 /= len(zz)) error stop 70
+ if (3 /= size(xx)) error stop 71
+ if (3 /= size(yy)) error stop 71
+ if (3 /= size(zz)) error stop 71
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (5 /= lbound(yy, dim=1)) stop 49
+ if (-k /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (7 /= ubound(yy, dim=1)) stop 49
+ if (-k+2 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (is_contiguous (xx)) error stop 79
+ if (is_contiguous (yy)) error stop 79
+ if (is_contiguous (zz)) error stop 79
+ if (xx(1) /= "abc") error stop 72
+ if (xx(2) /= "ghi") error stop 73
+ if (xx(3) /= "nop") error stop 74
+ if (yy(5) /= "abc") error stop 72
+ if (yy(6) /= "ghi") error stop 73
+ if (yy(7) /= "nop") error stop 74
+ if (zz(-k) /= "abc") error stop 72
+ if (zz(-k+1) /= "ghi") error stop 73
+ if (zz(-k+2) /= "nop") error stop 74
+ else if (num == 2) then
+ if (.not.is_contiguous (xx)) error stop 79
+ if (.not.is_contiguous (yy)) error stop 79
+ if (.not.is_contiguous (zz)) error stop 79
+ if (xx(1) /= "def") error stop 72
+ if (xx(2) /= "ghi") error stop 73
+ if (xx(3) /= "jlm") error stop 74
+ if (yy(5) /= "def") error stop 72
+ if (yy(6) /= "ghi") error stop 73
+ if (yy(7) /= "jlm") error stop 74
+ if (zz(-k) /= "def") error stop 72
+ if (zz(-k+1) /= "ghi") error stop 73
+ if (zz(-k+2) /= "jlm") error stop 74
+ else
+ error stop 78
+ endif
+ xx(1) = "ABC"
+ xx(2) = "DEF"
+ xx(3) = "GHI"
+ yy(5) = "ABC"
+ yy(6) = "DEF"
+ yy(7) = "GHI"
+ zz(-k) = "ABC"
+ zz(-k+1) = "DEF"
+ zz(-k+2) = "GHI"
+ res%x = get_loc(xx)
+ res%y = get_loc(yy)
+ res%z = get_loc(zz)
+contains
+ integer (c_intptr_t) function get_loc (arg)
+ character(len=*), target :: arg(:)
+ ! %loc does copy in/out if not simply contiguous
+ ! extra func needed because of 'target' attribute
+ get_loc = transfer (c_loc(arg), res%x)
+ end
+end
+
+type(loc_t) function char_assumed_shape_in_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*) :: xx(:)
+ character(len=3) :: yy(5:)
+ character(len=k) :: zz(-k:)
+ intent(in) :: xx, yy, zz
+ print *, xx(1:3)
+ if (3 /= size(xx)) error stop 80
+ if (3 /= size(yy)) error stop 80
+ if (3 /= size(zz)) error stop 80
+ if (3 /= len(xx)) error stop 81
+ if (3 /= len(yy)) error stop 81
+ if (3 /= len(zz)) error stop 81
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (5 /= lbound(yy, dim=1)) stop 49
+ if (-k /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (7 /= ubound(yy, dim=1)) stop 49
+ if (-k+2 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (is_contiguous (xx)) error stop 89
+ if (is_contiguous (yy)) error stop 89
+ if (is_contiguous (zz)) error stop 89
+ if (xx(1) /= "abc") error stop 82
+ if (xx(2) /= "ghi") error stop 83
+ if (xx(3) /= "nop") error stop 84
+ if (yy(5) /= "abc") error stop 82
+ if (yy(6) /= "ghi") error stop 83
+ if (yy(7) /= "nop") error stop 84
+ if (zz(-k) /= "abc") error stop 82
+ if (zz(-k+1) /= "ghi") error stop 83
+ if (zz(-k+2) /= "nop") error stop 84
+ else if (num == 2) then
+ if (.not.is_contiguous (xx)) error stop 89
+ if (.not.is_contiguous (yy)) error stop 89
+ if (.not.is_contiguous (zz)) error stop 89
+ if (xx(1) /= "def") error stop 85
+ if (xx(2) /= "ghi") error stop 86
+ if (xx(3) /= "jlm") error stop 87
+ if (yy(5) /= "def") error stop 85
+ if (yy(6) /= "ghi") error stop 86
+ if (yy(7) /= "jlm") error stop 87
+ if (zz(-k) /= "def") error stop 85
+ if (zz(-k+1) /= "ghi") error stop 86
+ if (zz(-k+2) /= "jlm") error stop 87
+ else
+ error stop 88
+ endif
+ res%x = get_loc(xx)
+ res%y = get_loc(yy)
+ res%z = get_loc(zz)
+contains
+ integer (c_intptr_t) function get_loc (arg)
+ character(len=*), target :: arg(:)
+ ! %loc does copy in/out if not simply contiguous
+ ! extra func needed because of 'target' attribute
+ get_loc = transfer (c_loc(arg), res%x)
+ end
+end
+
+
+
+type(loc_t) function char_assumed_shape_cont_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*) :: xx(:)
+ character(len=3) :: yy(5:)
+ character(len=k) :: zz(-k:)
+ contiguous :: xx, yy, zz
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 90
+ if (3 /= len(yy)) error stop 90
+ if (3 /= len(zz)) error stop 90
+ if (3 /= size(xx)) error stop 91
+ if (3 /= size(yy)) error stop 91
+ if (3 /= size(zz)) error stop 91
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (5 /= lbound(yy, dim=1)) stop 49
+ if (-k /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (7 /= ubound(yy, dim=1)) stop 49
+ if (-k+2 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 92
+ if (xx(2) /= "ghi") error stop 93
+ if (xx(3) /= "nop") error stop 94
+ if (yy(5) /= "abc") error stop 92
+ if (yy(6) /= "ghi") error stop 93
+ if (yy(7) /= "nop") error stop 94
+ if (zz(-k) /= "abc") error stop 92
+ if (zz(-k+1) /= "ghi") error stop 93
+ if (zz(-k+2) /= "nop") error stop 94
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 92
+ if (xx(2) /= "ghi") error stop 93
+ if (xx(3) /= "jlm") error stop 94
+ if (yy(5) /= "def") error stop 92
+ if (yy(6) /= "ghi") error stop 93
+ if (yy(7) /= "jlm") error stop 94
+ if (zz(-k) /= "def") error stop 92
+ if (zz(-k+1) /= "ghi") error stop 93
+ if (zz(-k+2) /= "jlm") error stop 94
+ else
+ error stop 98
+ endif
+ xx(1) = "ABC"
+ xx(2) = "DEF"
+ xx(3) = "GHI"
+ yy(5) = "ABC"
+ yy(6) = "DEF"
+ yy(7) = "GHI"
+ zz(-k) = "ABC"
+ zz(-k+1) = "DEF"
+ zz(-k+2) = "GHI"
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+type(loc_t) function char_assumed_shape_cont_in_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*) :: xx(:)
+ character(len=3) :: yy(5:)
+ character(len=k) :: zz(-k:)
+ intent(in) :: xx, yy, zz
+ contiguous :: xx, yy, zz
+ print *, xx(1:3)
+ if (3 /= size(xx)) error stop 100
+ if (3 /= size(yy)) error stop 100
+ if (3 /= size(zz)) error stop 100
+ if (3 /= len(xx)) error stop 101
+ if (3 /= len(yy)) error stop 101
+ if (3 /= len(zz)) error stop 101
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (5 /= lbound(yy, dim=1)) stop 49
+ if (-k /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (7 /= ubound(yy, dim=1)) stop 49
+ if (-k+2 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 102
+ if (xx(2) /= "ghi") error stop 103
+ if (xx(3) /= "nop") error stop 104
+ if (yy(5) /= "abc") error stop 102
+ if (yy(6) /= "ghi") error stop 103
+ if (yy(7) /= "nop") error stop 104
+ if (zz(-k) /= "abc") error stop 102
+ if (zz(-k+1) /= "ghi") error stop 103
+ if (zz(-k+2) /= "nop") error stop 104
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 105
+ if (xx(2) /= "ghi") error stop 106
+ if (xx(3) /= "jlm") error stop 107
+ if (yy(5) /= "def") error stop 105
+ if (yy(6) /= "ghi") error stop 106
+ if (yy(7) /= "jlm") error stop 107
+ if (zz(-k) /= "def") error stop 105
+ if (zz(-k+1) /= "ghi") error stop 106
+ if (zz(-k+2) /= "jlm") error stop 107
+ else
+ error stop 108
+ endif
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+end module
+
+
+use m
+implicit none (type, external)
+character(len=3) :: a(6), a2(6), a3(6), a_init(6)
+type(loc_t) :: loc3
+
+a_init = ['abc', 'def', 'ghi', 'jlm', 'nop', 'qrs']
+
+! -- Fortran: assumed size
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- Fortran: explicit shape
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- Fortran: assumed rank
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_f (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_in_f (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- Fortran: assumed rank contiguous
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- Fortran: assumed shape
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_f (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_in_f (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- Fortran: assumed shape contiguous
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+
+! --- character - call C directly --
+
+! -- C: assumed size
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- C: explicit shape
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- C: assumed rank
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_c (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_in_c (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- C: assumed rank contiguous
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- C: assumed shape
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_c (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_in_c (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- C: assumed shape contiguous
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+end
+
+
+! { dg-output "At line 928 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 928 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 928 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 946 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 946 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 946 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 965 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 965 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 965 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 983 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 983 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 983 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1039 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1039 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1039 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1057 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1057 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1057 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1113 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1113 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1113 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1131 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1131 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1131 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1153 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1153 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1153 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1171 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1171 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1171 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1190 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1190 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1190 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1208 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1208 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1208 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1264 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1264 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1264 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1282 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1282 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1282 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1338 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1338 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1338 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1356 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1356 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1356 of file .*bind-c-contiguous-1.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-2.f90 b/gcc/testsuite/gfortran.dg/bind-c-contiguous-2.f90
new file mode 100644
index 00000000000..5b546800e7f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-2.f90
@@ -0,0 +1,82 @@
+! { dg-additional-options "-fdump-tree-original" }
+
+integer function f(xx) bind(c) result(ii)
+ implicit none
+ integer, contiguous :: xx(..)
+ ii = rank(xx)
+end
+
+integer function h(yy) bind(c) result(jj)
+ implicit none
+ character(len=*), contiguous :: yy(:)
+ jj = rank(yy)
+end
+
+integer function g(zz) bind(c) result(kk)
+ implicit none
+ character(len=*) :: zz(*)
+ kk = rank(zz)
+end
+
+
+
+integer function f2(aa) bind(c) result(ii)
+ implicit none
+ integer, contiguous :: aa(..)
+ intent(in) :: aa
+ ii = rank(aa)
+end
+
+integer function h2(bb) bind(c) result(jj)
+ implicit none
+ character(len=*), contiguous :: bb(:)
+ intent(in) :: bb
+ jj = rank(bb)
+end
+
+integer function g2(cc) bind(c) result(kk)
+ implicit none
+ character(len=*) :: cc(*)
+ intent(in) :: cc
+ kk = rank(cc)
+end
+
+!
+! Copy-in/out variable:
+!
+! { dg-final { scan-tree-dump-times "xx->data =\[^;\]+ __builtin_malloc \\(_xx->elem_len \\* size.\[0-9\]+\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "yy->data =\[^;\]+ __builtin_malloc \\(_yy->elem_len \\* size.\[0-9\]+\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "zz =\[^;\]+ __builtin_malloc \\(_zz->elem_len \\* size.\[0-9\]+\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "aa->data =\[^;\]+ __builtin_malloc \\(_aa->elem_len \\* size.\[0-9\]+\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bb->data =\[^;\]+ __builtin_malloc \\(_bb->elem_len \\* size.\[0-9\]+\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "cc =\[^;\]+ __builtin_malloc \\(_cc->elem_len \\* size.\[0-9\]+\\);" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "__builtin_free \\(\[^;\]+ xx->data\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free \\(\[^;\]+ yy->data\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free \\(zz\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free \\(\[^;\]+ aa->data\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free \\(\[^;\]+ bb->data\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_free \\(cc\\);" 1 "original" } }
+
+! Copy in + out
+
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) xx->data \\+ xx->dtype.elem_len \\* arrayidx.\[0-9\]+, _xx->base_addr \\+ shift.\[0-9\]+, xx->dtype.elem_len\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "xx->data = \\(void \\* restrict\\) _xx->base_addr;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) xx->data \\+ xx->dtype.elem_len \\* arrayidx.\[0-9\]+, _xx->base_addr \\+ shift.\[0-9\]+, xx->dtype.elem_len\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) yy->data \\+ yy->dtype.elem_len \\* arrayidx.\[0-9\]+, _yy->base_addr \\+ shift.\[0-9\]+, yy->dtype.elem_len\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "yy->data = \\(void \\* restrict\\) _yy->base_addr;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(_yy->base_addr \\+ shift.\[0-9\]+, \\(void \\*\\) yy->data \\+ yy->dtype.elem_len \\* arrayidx.\[0-9\]+, yy->dtype.elem_len\\);" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "zz = \\(character\\(kind=1\\)\\\[0:\\\]\\\[1:zz.\[0-9\]+\\\] \\* restrict\\) _zz->base_addr;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) zz \\+ _zz->elem_len \\* arrayidx.\[0-9\]+, _zz->base_addr \\+ shift.\[0-9\]+, _zz->elem_len\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(_zz->base_addr \\+ shift.\[0-9\]+, \\(void \\*\\) zz \\+ _zz->elem_len \\* arrayidx.\[0-9\]+, _zz->elem_len\\);" 1 "original" } }
+
+! Copy in only
+
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) aa->data \\+ aa->dtype.elem_len \\* arrayidx.\[0-9\]+, _aa->base_addr \\+ shift.\[0-9\]+, aa->dtype.elem_len\\);" 1 "original" } }
+
+! { dg-final { scan-tree-dump-times "aa->data = \\(void \\* restrict\\) _aa->base_addr;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) bb->data \\+ bb->dtype.elem_len \\* arrayidx.\[0-9\]+, _bb->base_addr \\+ shift.\[0-9\]+, bb->dtype.elem_len\\);" 1 "original" } }
+! { dg-final { scan-tree-dump-times "bb->data = \\(void \\* restrict\\) _bb->base_addr;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "cc = \\(character\\(kind=1\\)\\\[0:\\\]\\\[1:cc.\[0-9\]+\\\] \\* restrict\\) _cc->base_addr;" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_memcpy \\(\\(void \\*\\) cc \\+ _cc->elem_len \\* arrayidx.\[0-9\]+, _cc->base_addr \\+ shift.\[0-9\]+, _cc->elem_len\\);" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-3.c b/gcc/testsuite/gfortran.dg/bind-c-contiguous-3.c
new file mode 100644
index 00000000000..506f7532b3d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-3.c
@@ -0,0 +1,180 @@
+#include <ISO_Fortran_binding.h>
+
+intptr_t assumed_rank_alloc_f (CFI_cdesc_t *);
+intptr_t assumed_rank_pointer_f (CFI_cdesc_t *);
+intptr_t assumed_rank_f (CFI_cdesc_t *);
+intptr_t assumed_rank_cont_f (CFI_cdesc_t *);
+intptr_t assumed_shape_f (CFI_cdesc_t *);
+intptr_t assumed_shape_cont_f (CFI_cdesc_t *);
+intptr_t deferred_shape_alloc_f (CFI_cdesc_t *);
+intptr_t deferred_shape_pointer_f (CFI_cdesc_t *);
+
+
+static void
+basic_check(CFI_cdesc_t *x)
+{
+ if (!x->base_addr)
+ __builtin_abort ();
+ if (x->elem_len != sizeof(int32_t))
+ __builtin_abort ();
+ if (x->version != CFI_VERSION)
+ __builtin_abort ();
+ if (x->rank != 4)
+ __builtin_abort ();
+ if (x->type != CFI_type_int32_t)
+ __builtin_abort ();
+ if (x->attribute == CFI_attribute_other)
+ {
+ if (x->dim[0].lower_bound != 0)
+ __builtin_abort ();
+ if (x->dim[1].lower_bound != 0)
+ __builtin_abort ();
+ if (x->dim[2].lower_bound != 0)
+ __builtin_abort ();
+ if (x->dim[3].lower_bound != 0)
+ __builtin_abort ();
+ }
+}
+
+intptr_t
+assumed_rank_alloc_c (CFI_cdesc_t *x)
+{
+ basic_check (x);
+ if (!CFI_is_contiguous (x))
+ __builtin_abort ();
+ if (x->attribute != CFI_attribute_allocatable)
+ __builtin_abort ();
+ intptr_t addr = (intptr_t) x->base_addr;
+ intptr_t addr2 = assumed_rank_alloc_f (x);
+ if (addr != addr2 || addr != (intptr_t) x->base_addr)
+ __builtin_abort ();
+ return addr;
+}
+
+intptr_t
+assumed_rank_pointer_c (CFI_cdesc_t *x)
+{
+ basic_check (x);
+ if (x->attribute != CFI_attribute_pointer)
+ __builtin_abort ();
+ intptr_t addr = (intptr_t) x->base_addr;
+ intptr_t addr2 = assumed_rank_pointer_f (x);
+ if (addr != addr2 || addr != (intptr_t) x->base_addr)
+ __builtin_abort ();
+ return addr;
+}
+
+
+intptr_t
+assumed_rank_c (CFI_cdesc_t *x)
+{
+ basic_check (x);
+ if (x->attribute != CFI_attribute_other)
+ __builtin_abort ();
+ intptr_t addr = (intptr_t) x->base_addr;
+ intptr_t addr2 = assumed_rank_f (x);
+ if (addr != addr2 || addr != (intptr_t) x->base_addr)
+ __builtin_abort ();
+ return addr;
+}
+
+intptr_t
+assumed_rank_cont_c (CFI_cdesc_t *x)
+{
+ basic_check (x);
+ if (!CFI_is_contiguous (x))
+ __builtin_abort ();
+ if (x->attribute != CFI_attribute_other)
+ __builtin_abort ();
+ intptr_t addr = (intptr_t) x->base_addr;
+ intptr_t addr2 = assumed_rank_cont_f (x);
+ if (addr != addr2 || addr != (intptr_t) x->base_addr)
+ __builtin_abort ();
+ return addr;
+}
+
+intptr_t
+assumed_shape_c (CFI_cdesc_t *x, int num)
+{
+ basic_check (x);
+ if (x->attribute != CFI_attribute_other)
+ __builtin_abort ();
+ intptr_t addr = (intptr_t) x->base_addr;
+ intptr_t addr2;
+ if (num == 1 || num == 2 || num == 3)
+ {
+ if (!CFI_is_contiguous (x))
+ __builtin_abort ();
+ }
+ else
+ {
+ if (CFI_is_contiguous (x))
+ __builtin_abort ();
+ }
+
+ if (num == 1 || num == 4)
+ addr2 = assumed_shape_f (x);
+ else if (num == 2 || num == 5)
+ addr2 = assumed_shape_cont_f (x);
+ else if (num == 3 || num == 6)
+ addr2 = assumed_rank_cont_f (x);
+ else
+ __builtin_abort ();
+
+ if (num == 1 || num == 2 || num == 3)
+ {
+ if (addr != addr2)
+ __builtin_abort ();
+ }
+ else
+ {
+ if (CFI_is_contiguous (x))
+ __builtin_abort ();
+ }
+ if (addr != (intptr_t) x->base_addr)
+ __builtin_abort ();
+ return addr2;
+}
+
+intptr_t
+assumed_shape_cont_c (CFI_cdesc_t *x)
+{
+ basic_check (x);
+ if (!CFI_is_contiguous (x))
+ __builtin_abort ();
+ if (x->attribute != CFI_attribute_other)
+ __builtin_abort ();
+ intptr_t addr = (intptr_t) x->base_addr;
+ intptr_t addr2 = assumed_shape_cont_f (x);
+ if (addr != addr2 || addr != (intptr_t) x->base_addr)
+ __builtin_abort ();
+ return addr;
+}
+
+intptr_t
+deferred_shape_alloc_c (CFI_cdesc_t *x)
+{
+ basic_check (x);
+ if (!CFI_is_contiguous (x))
+ __builtin_abort ();
+ if (x->attribute != CFI_attribute_allocatable)
+ __builtin_abort ();
+ intptr_t addr = (intptr_t) x->base_addr;
+ intptr_t addr2 = deferred_shape_alloc_f (x);
+ if (addr != addr2 || addr != (intptr_t) x->base_addr)
+ __builtin_abort ();
+ return addr;
+}
+
+intptr_t
+deferred_shape_pointer_c (CFI_cdesc_t *x)
+{
+ basic_check (x);
+ if (x->attribute != CFI_attribute_pointer)
+ __builtin_abort ();
+ intptr_t addr = (intptr_t) x->base_addr;
+ intptr_t addr2 = deferred_shape_pointer_f (x);
+ if (addr != addr2 || addr != (intptr_t) x->base_addr)
+ __builtin_abort ();
+ return addr;
+}
diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-3.f90 b/gcc/testsuite/gfortran.dg/bind-c-contiguous-3.f90
new file mode 100644
index 00000000000..6e479ffc75a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-3.f90
@@ -0,0 +1,656 @@
+! { dg-do run }
+! { dg-additional-sources bind-c-contiguous-3.c }
+
+! Test that multi-dim contiguous is properly handled.
+
+module m
+ use iso_c_binding, only: c_intptr_t, c_int
+ implicit none (type, external)
+
+interface
+ integer(c_intptr_t) function assumed_rank_alloc_c (xx) bind(c)
+ import :: c_intptr_t
+ integer, allocatable :: xx(..)
+ end function
+ integer(c_intptr_t) function assumed_rank_pointer_c (xx) bind(c)
+ import :: c_intptr_t
+ integer, pointer :: xx(..)
+ end function
+ integer(c_intptr_t) function assumed_rank_c (xx) bind(c)
+ import :: c_intptr_t
+ integer :: xx(..)
+ end function
+ integer(c_intptr_t) function assumed_rank_cont_c (xx) bind(c)
+ import :: c_intptr_t
+ integer, contiguous :: xx(..)
+ end function
+ integer(c_intptr_t) function assumed_shape_c (xx, num) bind(c)
+ import :: c_intptr_t, c_int
+ integer :: xx(:,:,:,:)
+ integer(c_int), value :: num
+ end function
+ integer(c_intptr_t) function assumed_shape_cont_c (xx) bind(c)
+ import :: c_intptr_t
+ integer, contiguous :: xx(:,:,:,:)
+ end function
+ integer(c_intptr_t) function deferred_shape_alloc_c (xx) bind(c)
+ import :: c_intptr_t
+ integer, allocatable :: xx(:,:,:,:)
+ end function
+ integer(c_intptr_t) function deferred_shape_pointer_c (xx) bind(c)
+ import :: c_intptr_t
+ integer, pointer :: xx(:,:,:,:)
+ end function
+
+end interface
+
+contains
+
+integer function get_n (idx, lbound, extent) result(res)
+ integer, contiguous :: idx(:), lbound(:), extent(:)
+ integer :: i
+ if (size(idx) /= size(lbound) .or. size(idx) /= size(extent)) &
+ error stop 20
+ res = idx(1) - lbound(1) + 1
+ do i = 2, size(idx)
+ res = res + product(extent(:i-1)) * (idx(i)-lbound(i))
+ end do
+end
+
+integer(c_intptr_t) function assumed_rank_alloc_f (xx) bind(c) result(res)
+ integer, allocatable :: xx(..)
+ integer :: i, j, k, l, lb(4)
+ select rank (xx)
+ rank (4)
+ do l = lbound(xx, dim=4), ubound(xx, dim=4)
+ do k = lbound(xx, dim=3), ubound(xx, dim=3)
+ do j = lbound(xx, dim=2), ubound(xx, dim=2)
+ do i = lbound(xx, dim=1), ubound(xx, dim=1)
+ xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
+ end do
+ end do
+ end do
+ end do
+ lb = lbound(xx)
+ res = %loc(xx(lb(1),lb(2),lb(3),lb(4))) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+end
+
+integer(c_intptr_t) function assumed_rank_pointer_f (xx) bind(c) result(res)
+ integer, pointer :: xx(..)
+ integer :: i, j, k, l, lb(4)
+ select rank (xx)
+ rank (4)
+ do l = lbound(xx, dim=4), ubound(xx, dim=4)
+ do k = lbound(xx, dim=3), ubound(xx, dim=3)
+ do j = lbound(xx, dim=2), ubound(xx, dim=2)
+ do i = lbound(xx, dim=1), ubound(xx, dim=1)
+ xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
+ end do
+ end do
+ end do
+ end do
+ lb = lbound(xx)
+ res = %loc(xx(lb(1),lb(2),lb(3),lb(4))) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+end
+
+
+integer(c_intptr_t) function assumed_rank_f (xx) bind(c) result(res)
+ integer :: xx(..)
+ integer :: i, j, k, l
+ select rank (xx)
+ rank (4)
+ do l = 1, size(xx, dim=4)
+ do k = 1, size(xx, dim=3)
+ do j = 1, size(xx, dim=2)
+ do i = 1, size(xx, dim=1)
+ xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
+ end do
+ end do
+ end do
+ end do
+ res = %loc(xx(1,1,1,1)) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+end
+
+integer(c_intptr_t) function assumed_rank_cont_f (xx) bind(c) result(res)
+ integer, contiguous :: xx(..)
+ integer :: i, j, k, l
+ select rank (xx)
+ rank (4)
+ do l = 1, size(xx, dim=4)
+ do k = 1, size(xx, dim=3)
+ do j = 1, size(xx, dim=2)
+ do i = 1, size(xx, dim=1)
+ xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
+ end do
+ end do
+ end do
+ end do
+ res = %loc(xx(1,1,1,1)) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+end
+
+integer(c_intptr_t) function assumed_shape_f (xx) bind(c) result(res)
+ integer :: xx(:,:,:,:)
+ integer :: i, j, k, l
+ do l = 1, ubound(xx, dim=4)
+ do k = 1, ubound(xx, dim=3)
+ do j = 1, ubound(xx, dim=2)
+ do i = 1, ubound(xx, dim=1)
+ xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
+ end do
+ end do
+ end do
+ end do
+ res = %loc(xx(1,1,1,1)) ! { dg-warning "Legacy Extension" }
+end
+
+integer(c_intptr_t) function assumed_shape2_f (xx, n) bind(c) result(res)
+ integer, value :: n
+ integer :: xx(-n:, -n:, -n:, -n:)
+ integer :: i, j, k, l
+ do l = -n, ubound(xx, dim=4)
+ do k = -n, ubound(xx, dim=3)
+ do j = -n, ubound(xx, dim=2)
+ do i = -n, ubound(xx, dim=1)
+ xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
+ end do
+ end do
+ end do
+ end do
+ res = %loc(xx(-n,-n,-n,-n)) ! { dg-warning "Legacy Extension" }
+end
+
+integer(c_intptr_t) function assumed_shape_cont_f (xx) bind(c) result(res)
+ integer, contiguous :: xx(:,:,:,:)
+ integer :: i, j, k, l
+ do l = 1, ubound(xx, dim=4)
+ do k = 1, ubound(xx, dim=3)
+ do j = 1, ubound(xx, dim=2)
+ do i = 1, ubound(xx, dim=1)
+ xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
+ end do
+ end do
+ end do
+ end do
+ res = %loc(xx(1,1,1,1)) ! { dg-warning "Legacy Extension" }
+end
+
+integer(c_intptr_t) function assumed_shape2_cont_f (xx, n) bind(c) result(res)
+ integer, value :: n
+ integer, contiguous :: xx(-n:, -n:, -n:, -n:)
+ integer :: i, j, k, l
+ do l = -n, ubound(xx, dim=4)
+ do k = -n, ubound(xx, dim=3)
+ do j = -n, ubound(xx, dim=2)
+ do i = -n, ubound(xx, dim=1)
+ xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
+ end do
+ end do
+ end do
+ end do
+ res = %loc(xx(-n,-n,-n,-n)) ! { dg-warning "Legacy Extension" }
+end
+
+integer(c_intptr_t) function deferred_shape_alloc_f (xx) bind(c) result(res)
+ integer, allocatable :: xx(:,:,:,:)
+ integer :: i, j, k, l, lb(4)
+ do l = lbound(xx, dim=4), ubound(xx, dim=4)
+ do k = lbound(xx, dim=3), ubound(xx, dim=3)
+ do j = lbound(xx, dim=2), ubound(xx, dim=2)
+ do i = lbound(xx, dim=1), ubound(xx, dim=1)
+ xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
+ end do
+ end do
+ end do
+ end do
+ lb = lbound(xx)
+ res = %loc(xx(lb(1),lb(2),lb(3),lb(4))) ! { dg-warning "Legacy Extension" }
+end
+
+integer(c_intptr_t) function deferred_shape_pointer_f (xx) bind(c) result(res)
+ integer, pointer :: xx(:,:,:,:)
+ integer :: i, j, k, l, lb(4)
+ do l = lbound(xx, dim=4), ubound(xx, dim=4)
+ do k = lbound(xx, dim=3), ubound(xx, dim=3)
+ do j = lbound(xx, dim=2), ubound(xx, dim=2)
+ do i = lbound(xx, dim=1), ubound(xx, dim=1)
+ xx(i,j,k,l) = -get_n([i,j,k,l], lbound(xx), shape(xx))
+ end do
+ end do
+ end do
+ end do
+ lb = lbound(xx)
+ res = %loc(xx(lb(1),lb(2),lb(3),lb(4))) ! { dg-warning "Legacy Extension" }
+end
+end module
+
+
+use m
+implicit none (type, external)
+integer, dimension(10,10,10,10) :: var_init, var
+target :: var
+integer, allocatable, dimension(:,:,:,:) :: a1, a2
+integer, pointer, dimension(:,:,:,:) :: p1, p2
+integer(c_intptr_t) :: loc4
+integer :: i, k, j, l, cnt
+
+do l = 1, ubound(var_init, dim=4)
+ do k = 1, ubound(var_init, dim=3)
+ do j = 1, ubound(var_init, dim=2)
+ do i = 1, ubound(var_init, dim=1)
+ var_init(i,j,k,l) = get_n([i,j,k,l], lbound(var_init), shape(var_init))
+ end do
+ end do
+ end do
+end do
+
+! Fortran calls
+
+! ----- allocatable + pointer dummies -------
+
+allocate(a1, mold=var_init)
+allocate(p1, mold=var_init)
+allocate(a2(-5:4,-10:-1,1:10,11:20))
+allocate(p2(-5:4,-10:-1,1:10,11:20))
+
+a1(:,:,:,:) = var_init
+loc4 = assumed_rank_alloc_f (a1)
+cnt = size(a1) - check_unmod (a1)
+call check (a1, loc4, .true., cnt)
+call check2 (a1)
+
+a2(:,:,:,:) = var_init
+loc4 = assumed_rank_alloc_f (a2)
+cnt = size(a2) - check_unmod (a2)
+call check (a2, loc4, .true., cnt)
+call check2 (a2)
+
+a1(:,:,:,:) = var_init
+loc4 = deferred_shape_alloc_f (a1)
+cnt = size(a1) - check_unmod (a1)
+call check (a1, loc4, .true., cnt)
+call check2 (a1)
+
+a2(:,:,:,:) = var_init
+loc4 = deferred_shape_alloc_f (a2)
+cnt = size(a2) - check_unmod (a2)
+call check (a2, loc4, .true., cnt)
+call check2 (a2)
+
+deallocate(a1, a2)
+
+p1(:,:,:,:) = var_init
+loc4 = assumed_rank_pointer_f (p1)
+cnt = size(p1) - check_unmod (p1)
+call check (p1, loc4, .true., cnt)
+call check2 (p1)
+
+p2(:,:,:,:) = var_init
+loc4 = assumed_rank_pointer_f (p2)
+cnt = size(p2) - check_unmod (p2)
+call check (p2, loc4, .true., cnt)
+call check2 (p2)
+
+p1(:,:,:,:) = var_init
+loc4 = deferred_shape_pointer_f (p1)
+cnt = size(p1) - check_unmod (p1)
+call check (p1, loc4, .true., cnt)
+call check2 (p1)
+
+p2(:,:,:,:) = var_init
+loc4 = deferred_shape_pointer_f (p2)
+cnt = size(p2) - check_unmod (p2)
+call check (p2, loc4, .true., cnt)
+call check2 (p2)
+
+deallocate(p1, p2)
+
+! --- p => var(4:7,::3,::2,:)
+var = var_init
+p1 => var(4:7,::3,::2,:)
+loc4 = assumed_rank_pointer_f (p1)
+cnt = size(p1) - check_unmod (p1)
+call check (p1, loc4, .false., cnt)
+call check2 (p1)
+
+var = var_init
+p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:)
+loc4 = assumed_rank_pointer_f (p2)
+cnt = size(p2) - check_unmod (p2)
+call check (p2, loc4, .false., cnt)
+call check2 (p2)
+
+var = var_init
+p1 => var(4:7,::3,::2,:)
+loc4 = deferred_shape_pointer_f (p1)
+cnt = size(p1) - check_unmod (p1)
+call check (p1, loc4, .false., cnt)
+call check2 (p1)
+
+var = var_init
+p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:)
+loc4 = deferred_shape_pointer_f (p2)
+cnt = size(p2) - check_unmod (p2)
+call check (p2, loc4, .false., cnt)
+call check2 (p2)
+
+
+
+! ----- nonallocatable + nonpointer dummies -------
+
+var = var_init
+loc4 = assumed_rank_f (var)
+cnt = size(var) - check_unmod (var)
+call check (var, loc4, .false., cnt)
+call check2 (var)
+
+var = var_init
+loc4 = assumed_shape_f (var)
+cnt = size(var) - check_unmod (var)
+call check (var, loc4, .false., cnt)
+call check2 (var)
+
+var = var_init
+loc4 = assumed_shape2_f (var, 99)
+cnt = size(var) - check_unmod (var)
+call check (var, loc4, .false., cnt)
+call check2 (var)
+
+var = var_init
+loc4 = assumed_rank_cont_f (var)
+cnt = size(var) - check_unmod (var)
+call check (var, loc4, .true., cnt)
+call check2 (var)
+
+var = var_init
+loc4 = assumed_shape_cont_f (var)
+cnt = size(var) - check_unmod (var)
+call check (var, loc4, .true., cnt)
+call check2 (var)
+
+var = var_init
+loc4 = assumed_shape2_cont_f (var, 99)
+cnt = size(var) - check_unmod (var)
+call check (var, loc4, .true., cnt)
+call check2 (var)
+
+! --- var(4:7,::3,::2,:)
+
+var = var_init
+loc4 = assumed_rank_f (var(4:7,::3,::2,:))
+cnt = size(var) - check_unmod (var)
+call check (var(4:7,::3,::2,:), loc4, .false., cnt)
+call check2 (var(4:7,::3,::2,:))
+
+var = var_init
+loc4 = assumed_shape_f (var(4:7,::3,::2,:))
+cnt = size(var) - check_unmod (var)
+call check (var(4:7,::3,::2,:), loc4, .false., cnt)
+call check2 (var(4:7,::3,::2,:))
+
+var = var_init
+loc4 = assumed_shape2_f (var(4:7,::3,::2,:), 99)
+cnt = size(var) - check_unmod (var)
+call check (var(4:7,::3,::2,:), loc4, .false., cnt)
+call check2 (var(4:7,::3,::2,:))
+
+var = var_init
+loc4 = assumed_rank_cont_f (var(4:7,::3,::2,:))
+cnt = size(var) - check_unmod (var)
+call check (var(4:7,::3,::2,:), loc4, .true., cnt)
+call check2 (var(4:7,::3,::2,:))
+
+var = var_init
+loc4 = assumed_shape_cont_f (var(4:7,::3,::2,:))
+cnt = size(var) - check_unmod (var)
+call check (var(4:7,::3,::2,:), loc4, .true., cnt)
+call check2 (var(4:7,::3,::2,:))
+
+var = var_init
+loc4 = assumed_shape2_cont_f (var(4:7,::3,::2,:), 99)
+cnt = size(var) - check_unmod (var)
+call check (var(4:7,::3,::2,:), loc4, .true., cnt)
+call check2 (var(4:7,::3,::2,:))
+
+
+! C calls
+
+! ----- allocatable + pointer dummies -------
+
+allocate(a1, mold=var_init)
+allocate(p1, mold=var_init)
+allocate(a2(-5:4,-10:-1,1:10,11:20))
+allocate(p2(-5:4,-10:-1,1:10,11:20))
+
+a1(:,:,:,:) = var_init
+loc4 = assumed_rank_alloc_c (a1)
+cnt = size(a1) - check_unmod (a1)
+call check (a1, loc4, .true., cnt)
+call check2 (a1)
+
+a2(:,:,:,:) = var_init
+loc4 = assumed_rank_alloc_c (a2)
+cnt = size(a2) - check_unmod (a2)
+call check (a2, loc4, .true., cnt)
+call check2 (a2)
+
+a1(:,:,:,:) = var_init
+loc4 = deferred_shape_alloc_c (a1)
+cnt = size(a1) - check_unmod (a1)
+call check (a1, loc4, .true., cnt)
+call check2 (a1)
+
+a2(:,:,:,:) = var_init
+loc4 = deferred_shape_alloc_c (a2)
+cnt = size(a2) - check_unmod (a2)
+call check (a2, loc4, .true., cnt)
+call check2 (a2)
+
+deallocate(a1, a2)
+
+p1(:,:,:,:) = var_init
+loc4 = assumed_rank_pointer_c (p1)
+cnt = size(p1) - check_unmod (p1)
+call check (p1, loc4, .true., cnt)
+call check2 (p1)
+
+p2(:,:,:,:) = var_init
+loc4 = assumed_rank_pointer_c (p2)
+cnt = size(p2) - check_unmod (p2)
+call check (p2, loc4, .true., cnt)
+call check2 (p2)
+
+p1(:,:,:,:) = var_init
+loc4 = deferred_shape_pointer_c (p1)
+cnt = size(p1) - check_unmod (p1)
+call check (p1, loc4, .true., cnt)
+call check2 (p1)
+
+p2(:,:,:,:) = var_init
+loc4 = deferred_shape_pointer_c (p2)
+cnt = size(p2) - check_unmod (p2)
+call check (p2, loc4, .true., cnt)
+call check2 (p2)
+
+deallocate(p1, p2)
+
+! --- p => var(4:7,::3,::2,:)
+var = var_init
+p1 => var(4:7,::3,::2,:)
+loc4 = assumed_rank_pointer_c (p1)
+cnt = size(p1) - check_unmod (p1)
+call check (p1, loc4, .false., cnt)
+call check2 (p1)
+
+var = var_init
+p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:)
+loc4 = assumed_rank_pointer_c (p2)
+cnt = size(p2) - check_unmod (p2)
+call check (p2, loc4, .false., cnt)
+call check2 (p2)
+
+var = var_init
+p1 => var(4:7,::3,::2,:)
+loc4 = deferred_shape_pointer_c (p1)
+cnt = size(p1) - check_unmod (p1)
+call check (p1, loc4, .false., cnt)
+call check2 (p1)
+
+var = var_init
+p2(-5:,-10:,1:,11:) => var(4:7,::3,::2,:)
+loc4 = deferred_shape_pointer_c (p2)
+cnt = size(p2) - check_unmod (p2)
+call check (p2, loc4, .false., cnt)
+call check2 (p2)
+
+
+! ----- nonallocatable + nonpointer dummies -------
+
+var = var_init
+loc4 = assumed_rank_c (var)
+cnt = size(var) - check_unmod (var)
+call check (var, loc4, .false., cnt)
+call check2 (var)
+
+var = var_init
+! calls assumed_shape_f
+loc4 = assumed_shape_c (var, num=1)
+cnt = size(var) - check_unmod (var)
+call check (var, loc4, .false., cnt)
+call check2 (var)
+
+var = var_init
+! calls assumed_shape_cont_f
+loc4 = assumed_shape_c (var, num=2)
+cnt = size(var) - check_unmod (var)
+call check (var, loc4, .true., cnt)
+call check2 (var)
+
+var = var_init
+! calls assumed_rank_cont_f
+loc4 = assumed_shape_c (var, num=3)
+cnt = size(var) - check_unmod (var)
+call check (var, loc4, .true., cnt)
+call check2 (var)
+
+var = var_init
+loc4 = assumed_rank_cont_c (var)
+cnt = size(var) - check_unmod (var)
+call check (var, loc4, .true., cnt)
+call check2 (var)
+
+var = var_init
+loc4 = assumed_shape_cont_c (var)
+cnt = size(var) - check_unmod (var)
+call check (var, loc4, .true., cnt)
+call check2 (var)
+
+! --- var(4:7,::3,::2,:)
+
+var = var_init
+loc4 = assumed_rank_c (var(4:7,::3,::2,:))
+cnt = size(var) - check_unmod (var)
+call check (var(4:7,::3,::2,:), loc4, .false., cnt)
+call check2 (var(4:7,::3,::2,:))
+
+var = var_init
+! calls assumed_shape_f
+loc4 = assumed_shape_c (var(4:7,::3,::2,:), num=4)
+cnt = size(var) - check_unmod (var)
+call check (var(4:7,::3,::2,:), loc4, .false., cnt)
+call check2 (var(4:7,::3,::2,:))
+
+var = var_init
+! calls assumed_shape_cont_f
+loc4 = assumed_shape_c (var(4:7,::3,::2,:), num=5)
+cnt = size(var) - check_unmod (var)
+call check (var(4:7,::3,::2,:), loc4, .true., cnt)
+call check2 (var(4:7,::3,::2,:))
+
+var = var_init
+! calls assumed_rank_cont_f
+loc4 = assumed_shape_c (var(4:7,::3,::2,:), num=6)
+cnt = size(var) - check_unmod (var)
+call check (var(4:7,::3,::2,:), loc4, .true., cnt)
+call check2 (var(4:7,::3,::2,:))
+
+var = var_init
+loc4 = assumed_rank_cont_c (var(4:7,::3,::2,:))
+cnt = size(var) - check_unmod (var)
+call check (var(4:7,::3,::2,:), loc4, .true., cnt)
+call check2 (var(4:7,::3,::2,:))
+
+var = var_init
+loc4 = assumed_shape_cont_c (var(4:7,::3,::2,:))
+cnt = size(var) - check_unmod (var)
+call check (var(4:7,::3,::2,:), loc4, .true., cnt)
+call check2 (var(4:7,::3,::2,:))
+
+
+contains
+
+! Ensure that the rest is still okay
+! Returns the number of elements >= 0
+integer function check_unmod (x) result(cnt)
+ integer, contiguous, intent(in) :: x(:,:,:,:)
+ integer :: i, k, j, l
+ cnt = 0
+ do l = 1, ubound(x, dim=4)
+ do k = 1, ubound(x, dim=3)
+ do j = 1, ubound(x, dim=2)
+ do i = 1, ubound(x, dim=1)
+ if (x(i,j,k,l) >= 0) then
+ cnt = cnt + 1
+ if (x(i,j,k,l) /= get_n([i,j,k,l], lbound(x), shape(x))) &
+ error stop 5
+ endif
+ end do
+ end do
+ end do
+ end do
+end
+
+subroutine check(x, loc1, cont, cnt)
+ integer, intent(in) :: x(:,:,:,:)
+ integer(c_intptr_t), intent(in), optional :: loc1
+ logical, intent(in), optional :: cont ! dummy has CONTIGUOUS attr
+ integer, intent(in), optional :: cnt
+ integer(c_intptr_t) :: loc2
+ integer :: i, k, j, l
+ if (present (loc1)) then
+ loc2 = %loc(x(1,1,1,1)) ! { dg-warning "Legacy Extension" }
+ if (is_contiguous (x) .or. .not.cont) then
+ if (loc1 /= loc2) error stop 1
+ else
+ if (loc1 == loc2) error stop 2
+ end if
+ if (cnt /= size(x)) error stop 3
+ end if
+ do l = 1, ubound(x, dim=4)
+ do k = 1, ubound(x, dim=3)
+ do j = 1, ubound(x, dim=2)
+ do i = 1, ubound(x, dim=1)
+ if (x(i,j,k,l) /= -get_n([i,j,k,l], lbound(x), shape(x))) &
+ error stop 4
+ end do
+ end do
+ end do
+ end do
+end
+
+subroutine check2(x)
+ integer, contiguous, intent(in) :: x(:,:,:,:)
+ call check(x)
+end subroutine
+end
diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-4.c b/gcc/testsuite/gfortran.dg/bind-c-contiguous-4.c
new file mode 100644
index 00000000000..cee1eb4782f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-4.c
@@ -0,0 +1,370 @@
+#include <ISO_Fortran_binding.h>
+#include <stdbool.h>
+#include <string.h>
+
+struct loc_t {
+ intptr_t x, y, z;
+};
+
+typedef struct loc_t (*ftn_fn) (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_size_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_size_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_expl_size_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_expl_size_in_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_rank_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_rank_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_rank_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_rank_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_shape_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_shape_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_shape_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_shape_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+
+static void
+basic_check(CFI_cdesc_t *x, bool is_cont)
+{
+ if (!x->base_addr)
+ __builtin_abort ();
+ if (x->elem_len != 3*sizeof(char))
+ __builtin_abort ();
+ if (x->version != CFI_VERSION)
+ __builtin_abort ();
+ if (x->rank != 1)
+ __builtin_abort ();
+ if (x->attribute != CFI_attribute_other)
+ __builtin_abort ();
+ if (x->type != CFI_type_char)
+ __builtin_abort ();
+ if (x->dim[0].lower_bound != 0)
+ __builtin_abort ();
+ if (x->dim[0].extent != 3)
+ __builtin_abort ();
+ if (CFI_is_contiguous (x) != (x->elem_len == x->dim[0].sm))
+ __builtin_abort ();
+ if (is_cont != CFI_is_contiguous (x))
+ __builtin_abort ();
+}
+
+static void
+print_str (void *p, size_t len)
+{
+ __builtin_printf ("DEBUG: >");
+ for (size_t i = 0; i < len; ++i)
+ __builtin_printf ("%c", ((const char*) p)[i]);
+ __builtin_printf ("<\n");
+}
+
+static void
+check_str (CFI_cdesc_t *x, const char *str, const CFI_index_t subscripts[])
+{
+ /* Avoid checking for '\0'. */
+ if (strncmp ((const char*) CFI_address (x, subscripts), str, strlen(str)) != 0)
+ __builtin_abort ();
+}
+
+static void
+set_str (CFI_cdesc_t *x, const char *str, const CFI_index_t subscripts[])
+{
+ char *p = CFI_address (x, subscripts);
+ size_t len = strlen (str);
+ if (x->elem_len != len)
+ __builtin_abort ();
+ for (size_t i = 0; i < len; ++i)
+ p[i] = str[i];
+}
+
+static struct loc_t
+do_call (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num, bool intent_in, ftn_fn fn, bool is_cont, bool fort_cont)
+{
+ const CFI_index_t zero[1] = { 0 };
+ const CFI_index_t one[1] = { 1 };
+ const CFI_index_t two[1] = { 2 };
+ struct loc_t addr1, addr2;
+ if (k != 3)
+ __builtin_abort ();
+
+ if (num == 3)
+ {
+ if (x != NULL)
+ __builtin_abort ();
+ if (y != NULL)
+ __builtin_abort ();
+ if (z != NULL)
+ __builtin_abort ();
+ addr2 = fn (x, y, z, 3, num);
+ if (addr2.x != -1 || addr2.y != -1 || addr2.z != -1)
+ __builtin_abort ();
+ return addr2;
+ }
+ if (x == NULL)
+ __builtin_abort ();
+ if (y == NULL)
+ __builtin_abort ();
+ if (z == NULL)
+ __builtin_abort ();
+ basic_check (x, is_cont || num == 2);
+ basic_check (y, is_cont || num == 2);
+ basic_check (z, is_cont || num == 2);
+ if (!is_cont && num == 1)
+ {
+ check_str (x, "abc", zero);
+ check_str (x, "ghi", one);
+ check_str (x, "nop", two);
+ check_str (y, "abc", zero);
+ check_str (y, "ghi", one);
+ check_str (y, "nop", two);
+ check_str (z, "abc", zero);
+ check_str (z, "ghi", one);
+ check_str (z, "nop", two);
+ }
+ else if (num == 1)
+ {
+ if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0)
+ __builtin_abort ();
+ }
+ else if (num == 2)
+ {
+ if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0)
+ __builtin_abort ();
+ }
+ else
+ __builtin_abort ();
+ addr1.x = (intptr_t) x->base_addr;
+ addr1.y = (intptr_t) y->base_addr;
+ addr1.z = (intptr_t) z->base_addr;
+ addr2 = fn (x, y, z, 3, num);
+ if (!CFI_is_contiguous (x) && fort_cont)
+ {
+ /* Check for callee copy in/copy out. */
+ if (addr1.x == addr2.x || addr1.x != (intptr_t) x->base_addr)
+ __builtin_abort ();
+ if (addr1.y == addr2.y || addr1.y != (intptr_t) y->base_addr)
+ __builtin_abort ();
+ if (addr1.z == addr2.z || addr1.z != (intptr_t) z->base_addr)
+ __builtin_abort ();
+ }
+ else
+ {
+ if (addr1.x != addr2.x || addr1.x != (intptr_t) x->base_addr)
+ __builtin_abort ();
+ if (addr1.y != addr2.y || addr1.y != (intptr_t) y->base_addr)
+ __builtin_abort ();
+ if (addr1.z != addr2.z || addr1.z != (intptr_t) z->base_addr)
+ __builtin_abort ();
+ }
+ // intent_in
+ if (intent_in && !is_cont && num == 1)
+ {
+ check_str (x, "abc", zero);
+ check_str (x, "ghi", one);
+ check_str (x, "nop", two);
+ check_str (y, "abc", zero);
+ check_str (y, "ghi", one);
+ check_str (y, "nop", two);
+ check_str (z, "abc", zero);
+ check_str (z, "ghi", one);
+ check_str (z, "nop", two);
+ }
+ else if (intent_in && num == 1)
+ {
+ if (strncmp ((const char*) x->base_addr, "abcghinop", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) y->base_addr, "abcghinop", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) z->base_addr, "abcghinop", 9) != 0)
+ __builtin_abort ();
+ }
+ else if (intent_in && num == 2)
+ {
+ if (strncmp ((const char*) x->base_addr, "defghijlm", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) y->base_addr, "defghijlm", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) z->base_addr, "defghijlm", 9) != 0)
+ __builtin_abort ();
+ }
+ else if (intent_in)
+ __builtin_abort ();
+ if (intent_in)
+ {
+ if (is_cont && num == 1)
+ {
+ /* Copy in - set the value to check that no copy out is done. */
+ memcpy ((char*) x->base_addr, "123456789", 9);
+ memcpy ((char*) y->base_addr, "123456789", 9);
+ memcpy ((char*) z->base_addr, "123456789", 9);
+ }
+ return addr1;
+ }
+ // !intent_in
+ if (!is_cont && num == 1)
+ {
+ check_str (x, "ABC", zero);
+ check_str (x, "DEF", one);
+ check_str (x, "GHI", two);
+ check_str (y, "ABC", zero);
+ check_str (y, "DEF", one);
+ check_str (y, "GHI", two);
+ check_str (z, "ABC", zero);
+ check_str (z, "DEF", one);
+ check_str (z, "GHI", two);
+ }
+ else
+ {
+ if (strncmp ((const char*) x->base_addr, "ABCDEFGHI", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) y->base_addr, "ABCDEFGHI", 9) != 0)
+ __builtin_abort ();
+ if (strncmp ((const char*) z->base_addr, "ABCDEFGHI", 9) != 0)
+ __builtin_abort ();
+ }
+ return addr1;
+}
+
+struct loc_t
+char_assumed_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_assumed_size_f, true, false);
+}
+
+struct loc_t
+char_assumed_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_size_in_f, true, false);
+}
+
+struct loc_t
+char_expl_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_expl_size_f, true, false);
+}
+
+struct loc_t
+char_expl_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_expl_size_in_f, true, false);
+}
+
+struct loc_t
+char_assumed_rank_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_assumed_rank_f, false, false);
+}
+
+struct loc_t
+char_assumed_rank_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_rank_in_f, false, false);
+}
+
+struct loc_t
+char_assumed_rank_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, true, false);
+}
+
+struct loc_t
+char_assumed_rank_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, true, false);
+}
+
+static void
+reset_var (CFI_cdesc_t *x, int num)
+{
+ const CFI_index_t zero[1] = { 0 };
+ const CFI_index_t one[1] = { 1 };
+ const CFI_index_t two[1] = { 2 };
+
+ if (num == 1)
+ {
+ set_str (x, "abc", zero);
+ set_str (x, "ghi", one);
+ set_str (x, "nop", two);
+ }
+ else if (num == 2)
+ {
+ set_str (x, "def", zero);
+ set_str (x, "ghi", one);
+ set_str (x, "jlm", two);
+ }
+ else if (num == 3)
+ {
+ if (x != NULL)
+ __builtin_abort ();
+ }
+ else
+ __builtin_abort ();
+}
+
+static void
+reset_vars (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, int num)
+{
+ reset_var (x, num);
+ reset_var (y, num);
+ reset_var (z, num);
+}
+
+struct loc_t
+char_assumed_shape_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ /* Make use of having a noncontiguous argument to check that the callee
+ handles noncontiguous variables. */
+ do_call (x, y, z, k, num, false, char_assumed_size_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, true, char_assumed_size_in_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, false, char_expl_size_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, true, char_expl_size_in_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, false, true);
+ /* Actual func call. */
+ reset_vars (x, y, z, num);
+ return do_call (x, y, z, k, num, false, char_assumed_shape_f, false, false);
+}
+
+struct loc_t
+char_assumed_shape_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_shape_in_f, false, false);
+}
+
+struct loc_t
+char_assumed_shape_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, true, false);
+}
+
+struct loc_t
+char_assumed_shape_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, true, false);
+}
diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-4.f90 b/gcc/testsuite/gfortran.dg/bind-c-contiguous-4.f90
new file mode 100644
index 00000000000..ab59b0b3854
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-4.f90
@@ -0,0 +1,1720 @@
+! { dg-do run }
+!
+! Same test as bind-c-contiguous-1.* but with OPTIONAL
+!
+! { dg-additional-sources bind-c-contiguous-4.c }
+! { dg-additional-options "-fcheck=all" }
+! { dg-prune-output "command-line option '-fcheck=.*' is valid for Fortran but not for C" }
+
+! Fortran demands that with bind(C), the callee ensure that for
+! * 'contiguous'
+! * len=* with explicit/assumed-size arrays
+! noncontiguous actual arguments are handled.
+! (in without bind(C) in gfortran, caller handles the copy in/out
+
+! Additionally, for a bind(C) callee, a Fortran-written caller
+! has to ensure the same (for contiguous + len=* to explicit-/assumed-size arrays)
+
+module m
+ use iso_c_binding, only: c_intptr_t, c_bool, c_loc, c_int
+ implicit none (type, external)
+
+ type, bind(C) :: loc_t
+ integer(c_intptr_t) :: x, y, z
+ end type loc_t
+
+interface
+ type(loc_t) function char_assumed_size_c (xx, yy, zz, n, num) bind(C)
+ import :: loc_t, c_bool, c_int
+ integer(c_int), value :: n, num
+ character(len=*), optional :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
+ end function
+
+ type(loc_t) function char_assumed_size_in_c (xx, yy, zz, n, num) bind(C)
+ import :: loc_t, c_bool, c_int
+ integer(c_int), value :: n, num
+ character(len=*), intent(in), optional :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
+ end function
+
+ type(loc_t) function char_expl_size_c (xx, yy, zz, n, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer(c_int), value :: n, num
+ character(len=*), optional :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3)
+ end function
+
+ type(loc_t) function char_expl_size_in_c (xx, yy, zz, n, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer(c_int), value :: n, num
+ character(len=*), intent(in), optional :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3)
+ end function
+
+ type(loc_t) function char_assumed_rank_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*), optional :: xx(..)
+ character(len=3), optional :: yy(..)
+ character(len=k), optional :: zz(..)
+ end function
+
+ type(loc_t) function char_assumed_rank_in_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*), intent(in), optional :: xx(..)
+ character(len=3), intent(in), optional :: yy(..)
+ character(len=k), intent(in), optional :: zz(..)
+ end function
+
+ type(loc_t) function char_assumed_rank_cont_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*), contiguous, optional :: xx(..)
+ character(len=3), contiguous, optional :: yy(..)
+ character(len=k), contiguous, optional :: zz(..)
+ end function
+
+ type(loc_t) function char_assumed_rank_cont_in_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*), contiguous, intent(in), optional :: xx(..)
+ character(len=3), contiguous, intent(in), optional :: yy(..)
+ character(len=k), contiguous, intent(in), optional :: zz(..)
+ end function
+
+ type(loc_t) function char_assumed_shape_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*), optional :: xx(:)
+ character(len=3), optional :: yy(5:)
+ character(len=k), optional :: zz(-k:)
+ end function
+
+ type(loc_t) function char_assumed_shape_in_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*), intent(in), optional :: xx(:)
+ character(len=3), intent(in), optional :: yy(5:)
+ character(len=k), intent(in), optional :: zz(-k:)
+ end function
+
+ type(loc_t) function char_assumed_shape_cont_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*), contiguous, optional :: xx(:)
+ character(len=3), contiguous, optional :: yy(5:)
+ character(len=k), contiguous, optional :: zz(-k:)
+ end function
+
+ type(loc_t) function char_assumed_shape_cont_in_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(len=*), contiguous, intent(in), optional :: xx(:)
+ character(len=3), contiguous, intent(in), optional :: yy(5:)
+ character(len=k), contiguous, intent(in), optional :: zz(-k:)
+ end function
+end interface
+
+contains
+
+type(loc_t) function char_assumed_size_f (xx, yy, zz, n, num) bind(c) result(res)
+ integer, value :: num, n
+ character(len=*), optional :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
+ if (num == 3) then
+ if (present (xx) .or. present (yy) .or. present (zz)) error stop 1
+ res%x = -1; res%y = -1; res%z = -1
+ return
+ end if
+ if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 1
+ if (3 /= len(yy)) error stop 1
+ if (3 /= len(zz)) error stop 1
+ if (1 /= lbound(xx,dim=1)) error stop 1
+ if (3 /= lbound(yy,dim=1)) error stop 1
+ if (6 /= lbound(zz,dim=1)) error stop 1
+ if (3 /= lbound(zz,dim=2)) error stop 1
+ if (3 /= lbound(zz,dim=3)) error stop 1
+ if (1 /= size(zz,dim=1)) error stop 1
+ if (1 /= size(zz,dim=2)) error stop 1
+ if (6 /= ubound(zz,dim=1)) error stop 1
+ if (3 /= ubound(zz,dim=2)) error stop 1
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "nop") error stop 4
+ if (yy(3) /= "abc") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "nop") error stop 4
+ if (zz(6,n,3) /= "abc") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "nop") error stop 4
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "jlm") error stop 4
+ if (yy(3) /= "def") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "jlm") error stop 4
+ if (zz(6,n,3) /= "def") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "jlm") error stop 4
+ else
+ error stop 8
+ endif
+ xx(1) = "ABC"
+ xx(2) = "DEF"
+ xx(3) = "GHI"
+ yy(3) = "ABC"
+ yy(4) = "DEF"
+ yy(5) = "GHI"
+ zz(6,n,3) = "ABC"
+ zz(6,n,4) = "DEF"
+ zz(6,n,5) = "GHI"
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+type(loc_t) function char_assumed_size_in_f (xx, yy, zz, n, num) bind(c) result(res)
+ integer, value :: num, n
+ character(len=*), optional :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
+ intent(in) :: xx, yy, zz
+ if (num == 3) then
+ if (present (xx) .or. present (yy) .or. present (zz)) error stop 1
+ res%x = -1; res%y = -1; res%z = -1
+ return
+ end if
+ if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 1
+ if (3 /= len(yy)) error stop 1
+ if (3 /= len(zz)) error stop 1
+ if (1 /= lbound(xx,dim=1)) error stop 1
+ if (3 /= lbound(yy,dim=1)) error stop 1
+ if (6 /= lbound(zz,dim=1)) error stop 1
+ if (3 /= lbound(zz,dim=2)) error stop 1
+ if (3 /= lbound(zz,dim=3)) error stop 1
+ if (1 /= size(zz,dim=1)) error stop 1
+ if (1 /= size(zz,dim=2)) error stop 1
+ if (6 /= ubound(zz,dim=1)) error stop 1
+ if (3 /= ubound(zz,dim=2)) error stop 1
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "nop") error stop 4
+ if (yy(3) /= "abc") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "nop") error stop 4
+ if (zz(6,n,3) /= "abc") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "nop") error stop 4
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "jlm") error stop 4
+ if (yy(3) /= "def") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "jlm") error stop 4
+ if (zz(6,n,3) /= "def") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "jlm") error stop 4
+ else
+ error stop 8
+ endif
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" } if (num == 1) then
+end
+
+type(loc_t) function char_expl_size_f (xx, yy, zz, n, num) bind(c) result(res)
+ integer, value :: num, n
+ character(len=*), optional :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2)
+ if (num == 3) then
+ if (present (xx) .or. present (yy) .or. present (zz)) error stop 1
+ res%x = -1; res%y = -1; res%z = -1
+ return
+ end if
+ if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 1
+ if (3 /= len(yy)) error stop 1
+ if (3 /= len(zz)) error stop 1
+ if (1 /= lbound(xx,dim=1)) error stop 1
+ if (3 /= lbound(yy,dim=1)) error stop 1
+ if (6 /= lbound(zz,dim=1)) error stop 1
+ if (3 /= lbound(zz,dim=2)) error stop 1
+ if (3 /= lbound(zz,dim=3)) error stop 1
+ if (3 /= size(xx,dim=1)) error stop 1
+ if (3 /= size(yy,dim=1)) error stop 1
+ if (1 /= size(zz,dim=1)) error stop 1
+ if (1 /= size(zz,dim=2)) error stop 1
+ if (3 /= size(zz,dim=3)) error stop 1
+ if (3 /= ubound(xx,dim=1)) error stop 1
+ if (5 /= ubound(yy,dim=1)) error stop 1
+ if (6 /= ubound(zz,dim=1)) error stop 1
+ if (3 /= ubound(zz,dim=2)) error stop 1
+ if (5 /= ubound(zz,dim=3)) error stop 1
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "nop") error stop 4
+ if (yy(3) /= "abc") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "nop") error stop 4
+ if (zz(6,n,3) /= "abc") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "nop") error stop 4
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "jlm") error stop 4
+ if (yy(3) /= "def") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "jlm") error stop 4
+ if (zz(6,n,3) /= "def") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "jlm") error stop 4
+ else
+ error stop 8
+ endif
+ xx(1) = "ABC"
+ xx(2) = "DEF"
+ xx(3) = "GHI"
+ yy(3) = "ABC"
+ yy(4) = "DEF"
+ yy(5) = "GHI"
+ zz(6,n,3) = "ABC"
+ zz(6,n,4) = "DEF"
+ zz(6,n,5) = "GHI"
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+type(loc_t) function char_expl_size_in_f (xx, yy, zz, n, num) bind(c) result(res)
+ integer, value :: num, n
+ character(len=*), optional :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2)
+ intent(in) :: xx, yy, zz
+ if (num == 3) then
+ if (present (xx) .or. present (yy) .or. present (zz)) error stop 1
+ res%x = -1; res%y = -1; res%z = -1
+ return
+ end if
+ if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 1
+ if (3 /= len(yy)) error stop 1
+ if (3 /= len(zz)) error stop 1
+ if (1 /= lbound(xx,dim=1)) error stop 1
+ if (3 /= lbound(yy,dim=1)) error stop 1
+ if (6 /= lbound(zz,dim=1)) error stop 1
+ if (3 /= lbound(zz,dim=2)) error stop 1
+ if (3 /= lbound(zz,dim=3)) error stop 1
+ if (3 /= size(xx,dim=1)) error stop 1
+ if (3 /= size(yy,dim=1)) error stop 1
+ if (1 /= size(zz,dim=1)) error stop 1
+ if (1 /= size(zz,dim=2)) error stop 1
+ if (3 /= size(zz,dim=3)) error stop 1
+ if (3 /= ubound(xx,dim=1)) error stop 1
+ if (5 /= ubound(yy,dim=1)) error stop 1
+ if (6 /= ubound(zz,dim=1)) error stop 1
+ if (3 /= ubound(zz,dim=2)) error stop 1
+ if (5 /= ubound(zz,dim=3)) error stop 1
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "nop") error stop 4
+ if (yy(3) /= "abc") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "nop") error stop 4
+ if (zz(6,n,3) /= "abc") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "nop") error stop 4
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 2
+ if (xx(2) /= "ghi") error stop 3
+ if (xx(3) /= "jlm") error stop 4
+ if (yy(3) /= "def") error stop 2
+ if (yy(4) /= "ghi") error stop 3
+ if (yy(5) /= "jlm") error stop 4
+ if (zz(6,n,3) /= "def") error stop 2
+ if (zz(6,n,4) /= "ghi") error stop 3
+ if (zz(6,n,5) /= "jlm") error stop 4
+ else
+ error stop 8
+ endif
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+
+type(loc_t) function char_assumed_rank_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*), optional :: xx(..)
+ character(len=3), optional :: yy(..)
+ character(len=k), optional :: zz(..)
+ if (num == 3) then
+ if (present (xx) .or. present (yy) .or. present (zz)) error stop 1
+ res%x = -1; res%y = -1; res%z = -1
+ return
+ end if
+ if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1
+ if (3 /= len(xx)) error stop 40
+ if (3 /= len(yy)) error stop 40
+ if (3 /= len(zz)) error stop 40
+ if (3 /= size(xx)) error stop 41
+ if (3 /= size(yy)) error stop 41
+ if (3 /= size(zz)) error stop 41
+ if (1 /= rank(xx)) error stop 49
+ if (1 /= rank(yy)) error stop 49
+ if (1 /= rank(zz)) error stop 49
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (1 /= lbound(yy, dim=1)) stop 49
+ if (1 /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (3 /= ubound(yy, dim=1)) stop 49
+ if (3 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (is_contiguous (xx)) error stop 49
+ if (is_contiguous (yy)) error stop 49
+ if (is_contiguous (zz)) error stop 49
+ else if (num == 2) then
+ if (.not. is_contiguous (xx)) error stop 49
+ if (.not. is_contiguous (yy)) error stop 49
+ if (.not. is_contiguous (zz)) error stop 49
+ else
+ error stop 48
+ end if
+ select rank (xx)
+ rank (1)
+ print *, xx(1:3)
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 42
+ if (xx(2) /= "ghi") error stop 43
+ if (xx(3) /= "nop") error stop 44
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 45
+ if (xx(2) /= "ghi") error stop 46
+ if (xx(3) /= "jlm") error stop 47
+ else
+ error stop 48
+ endif
+ xx(1) = "ABC"
+ xx(2) = "DEF"
+ xx(3) = "GHI"
+ res%x = get_loc (xx)
+ rank default
+ error stop 99
+ end select
+ select rank (yy)
+ rank (1)
+ print *, yy(1:3)
+ if (num == 1) then
+ if (yy(1) /= "abc") error stop 42
+ if (yy(2) /= "ghi") error stop 43
+ if (yy(3) /= "nop") error stop 44
+ else if (num == 2) then
+ if (yy(1) /= "def") error stop 45
+ if (yy(2) /= "ghi") error stop 46
+ if (yy(3) /= "jlm") error stop 47
+ else
+ error stop 48
+ endif
+ yy(1) = "ABC"
+ yy(2) = "DEF"
+ yy(3) = "GHI"
+ res%y = get_loc (yy)
+ rank default
+ error stop 99
+ end select
+ select rank (zz)
+ rank (1)
+ print *, zz(1:3)
+ if (num == 1) then
+ if (zz(1) /= "abc") error stop 42
+ if (zz(2) /= "ghi") error stop 43
+ if (zz(3) /= "nop") error stop 44
+ else if (num == 2) then
+ if (zz(1) /= "def") error stop 45
+ if (zz(2) /= "ghi") error stop 46
+ if (zz(3) /= "jlm") error stop 47
+ else
+ error stop 48
+ endif
+ zz(1) = "ABC"
+ zz(2) = "DEF"
+ zz(3) = "GHI"
+ res%z = get_loc (zz)
+ rank default
+ error stop 99
+ end select
+contains
+ integer (c_intptr_t) function get_loc (arg)
+ character(len=*), target :: arg(:)
+ ! %loc does copy in/out if not simply contiguous
+ ! extra func needed because of 'target' attribute
+ get_loc = transfer (c_loc(arg), res%x)
+ end
+end
+
+type(loc_t) function char_assumed_rank_in_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*), optional :: xx(..)
+ character(len=3), optional :: yy(..)
+ character(len=k), optional :: zz(..)
+ intent(in) :: xx, yy, zz
+ if (num == 3) then
+ if (present (xx) .or. present (yy) .or. present (zz)) error stop 1
+ res%x = -1; res%y = -1; res%z = -1
+ return
+ end if
+ if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1
+ if (3 /= size(yy)) error stop 50
+ if (3 /= len(yy)) error stop 51
+ if (1 /= rank(yy)) error stop 59
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (1 /= lbound(yy, dim=1)) stop 49
+ if (1 /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (3 /= ubound(yy, dim=1)) stop 49
+ if (3 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (is_contiguous (xx)) error stop 59
+ if (is_contiguous (yy)) error stop 59
+ if (is_contiguous (zz)) error stop 59
+ else if (num == 2) then
+ if (.not. is_contiguous (xx)) error stop 59
+ if (.not. is_contiguous (yy)) error stop 59
+ if (.not. is_contiguous (zz)) error stop 59
+ else
+ error stop 48
+ end if
+ select rank (xx)
+ rank (1)
+ print *, xx(1:3)
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 52
+ if (xx(2) /= "ghi") error stop 53
+ if (xx(3) /= "nop") error stop 54
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 55
+ if (xx(2) /= "ghi") error stop 56
+ if (xx(3) /= "jlm") error stop 57
+ else
+ error stop 58
+ endif
+ res%x = get_loc(xx)
+ rank default
+ error stop 99
+ end select
+ select rank (yy)
+ rank (1)
+ print *, yy(1:3)
+ if (num == 1) then
+ if (yy(1) /= "abc") error stop 52
+ if (yy(2) /= "ghi") error stop 53
+ if (yy(3) /= "nop") error stop 54
+ else if (num == 2) then
+ if (yy(1) /= "def") error stop 55
+ if (yy(2) /= "ghi") error stop 56
+ if (yy(3) /= "jlm") error stop 57
+ else
+ error stop 58
+ endif
+ res%y = get_loc(yy)
+ rank default
+ error stop 99
+ end select
+ select rank (zz)
+ rank (1)
+ print *, zz(1:3)
+ if (num == 1) then
+ if (zz(1) /= "abc") error stop 52
+ if (zz(2) /= "ghi") error stop 53
+ if (zz(3) /= "nop") error stop 54
+ else if (num == 2) then
+ if (zz(1) /= "def") error stop 55
+ if (zz(2) /= "ghi") error stop 56
+ if (zz(3) /= "jlm") error stop 57
+ else
+ error stop 58
+ endif
+ res%z = get_loc(zz)
+ rank default
+ error stop 99
+ end select
+contains
+ integer (c_intptr_t) function get_loc (arg)
+ character(len=*), target :: arg(:)
+ ! %loc does copy in/out if not simply contiguous
+ ! extra func needed because of 'target' attribute
+ get_loc = transfer (c_loc(arg), res%x)
+ end
+end
+
+
+
+type(loc_t) function char_assumed_rank_cont_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*), optional :: xx(..)
+ character(len=3), optional :: yy(..)
+ character(len=k), optional :: zz(..)
+ contiguous :: xx, yy, zz
+ if (num == 3) then
+ if (present (xx) .or. present (yy) .or. present (zz)) error stop 1
+ res%x = -1; res%y = -1; res%z = -1
+ return
+ end if
+ if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1
+ if (3 /= len(xx)) error stop 60
+ if (3 /= len(yy)) error stop 60
+ if (3 /= len(zz)) error stop 60
+ if (3 /= size(xx)) error stop 61
+ if (3 /= size(yy)) error stop 61
+ if (3 /= size(zz)) error stop 61
+ if (1 /= rank(xx)) error stop 69
+ if (1 /= rank(yy)) error stop 69
+ if (1 /= rank(zz)) error stop 69
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (1 /= lbound(yy, dim=1)) stop 49
+ if (1 /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (3 /= ubound(yy, dim=1)) stop 49
+ if (3 /= ubound(zz, dim=1)) stop 49
+ select rank (xx)
+ rank (1)
+ print *, xx(1:3)
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 62
+ if (xx(2) /= "ghi") error stop 63
+ if (xx(3) /= "nop") error stop 64
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 65
+ if (xx(2) /= "ghi") error stop 66
+ if (xx(3) /= "jlm") error stop 67
+ else
+ error stop 68
+ endif
+ xx(1) = "ABC"
+ xx(2) = "DEF"
+ xx(3) = "GHI"
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+ select rank (yy)
+ rank (1)
+ print *, yy(1:3)
+ if (num == 1) then
+ if (yy(1) /= "abc") error stop 62
+ if (yy(2) /= "ghi") error stop 63
+ if (yy(3) /= "nop") error stop 64
+ else if (num == 2) then
+ if (yy(1) /= "def") error stop 65
+ if (yy(2) /= "ghi") error stop 66
+ if (yy(3) /= "jlm") error stop 67
+ else
+ error stop 68
+ endif
+ yy(1) = "ABC"
+ yy(2) = "DEF"
+ yy(3) = "GHI"
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+ select rank (zz)
+ rank (1)
+ print *, zz(1:3)
+ if (num == 1) then
+ if (zz(1) /= "abc") error stop 62
+ if (zz(2) /= "ghi") error stop 63
+ if (zz(3) /= "nop") error stop 64
+ else if (num == 2) then
+ if (zz(1) /= "def") error stop 65
+ if (zz(2) /= "ghi") error stop 66
+ if (zz(3) /= "jlm") error stop 67
+ else
+ error stop 68
+ endif
+ zz(1) = "ABC"
+ zz(2) = "DEF"
+ zz(3) = "GHI"
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+end
+
+type(loc_t) function char_assumed_rank_cont_in_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*), optional :: xx(..)
+ character(len=3), optional :: yy(..)
+ character(len=k), optional :: zz(..)
+ intent(in) :: xx, yy, zz
+ contiguous :: xx, yy, zz
+ if (num == 3) then
+ if (present (xx) .or. present (yy) .or. present (zz)) error stop 1
+ res%x = -1; res%y = -1; res%z = -1
+ return
+ end if
+ if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1
+ if (3 /= size(xx)) error stop 30
+ if (3 /= size(yy)) error stop 30
+ if (3 /= size(zz)) error stop 30
+ if (3 /= len(xx)) error stop 31
+ if (3 /= len(yy)) error stop 31
+ if (3 /= len(zz)) error stop 31
+ if (1 /= rank(xx)) error stop 69
+ if (1 /= rank(yy)) error stop 69
+ if (1 /= rank(zz)) error stop 69
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (1 /= lbound(yy, dim=1)) stop 49
+ if (1 /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (3 /= ubound(yy, dim=1)) stop 49
+ if (3 /= ubound(zz, dim=1)) stop 49
+ select rank (xx)
+ rank (1)
+ print *, xx(1:3)
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 62
+ if (xx(2) /= "ghi") error stop 63
+ if (xx(3) /= "nop") error stop 64
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 65
+ if (xx(2) /= "ghi") error stop 66
+ if (xx(3) /= "jlm") error stop 67
+ else
+ error stop 68
+ endif
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+ select rank (yy)
+ rank (1)
+ print *, yy(1:3)
+ if (num == 1) then
+ if (yy(1) /= "abc") error stop 62
+ if (yy(2) /= "ghi") error stop 63
+ if (yy(3) /= "nop") error stop 64
+ else if (num == 2) then
+ if (yy(1) /= "def") error stop 65
+ if (yy(2) /= "ghi") error stop 66
+ if (yy(3) /= "jlm") error stop 67
+ else
+ error stop 68
+ endif
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+ select rank (zz)
+ rank (1)
+ print *, zz(1:3)
+ if (num == 1) then
+ if (zz(1) /= "abc") error stop 62
+ if (zz(2) /= "ghi") error stop 63
+ if (zz(3) /= "nop") error stop 64
+ else if (num == 2) then
+ if (zz(1) /= "def") error stop 65
+ if (zz(2) /= "ghi") error stop 66
+ if (zz(3) /= "jlm") error stop 67
+ else
+ error stop 68
+ endif
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+end
+
+type(loc_t) function char_assumed_shape_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*), optional :: xx(:)
+ character(len=3), optional :: yy(5:)
+ character(len=k), optional :: zz(-k:)
+ if (num == 3) then
+ if (present (xx) .or. present (yy) .or. present (zz)) error stop 1
+ res%x = -1; res%y = -1; res%z = -1
+ return
+ end if
+ if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 70
+ if (3 /= len(yy)) error stop 70
+ if (3 /= len(zz)) error stop 70
+ if (3 /= size(xx)) error stop 71
+ if (3 /= size(yy)) error stop 71
+ if (3 /= size(zz)) error stop 71
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (5 /= lbound(yy, dim=1)) stop 49
+ if (-k /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (7 /= ubound(yy, dim=1)) stop 49
+ if (-k+2 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (is_contiguous (xx)) error stop 79
+ if (is_contiguous (yy)) error stop 79
+ if (is_contiguous (zz)) error stop 79
+ if (xx(1) /= "abc") error stop 72
+ if (xx(2) /= "ghi") error stop 73
+ if (xx(3) /= "nop") error stop 74
+ if (yy(5) /= "abc") error stop 72
+ if (yy(6) /= "ghi") error stop 73
+ if (yy(7) /= "nop") error stop 74
+ if (zz(-k) /= "abc") error stop 72
+ if (zz(-k+1) /= "ghi") error stop 73
+ if (zz(-k+2) /= "nop") error stop 74
+ else if (num == 2) then
+ if (.not.is_contiguous (xx)) error stop 79
+ if (.not.is_contiguous (yy)) error stop 79
+ if (.not.is_contiguous (zz)) error stop 79
+ if (xx(1) /= "def") error stop 72
+ if (xx(2) /= "ghi") error stop 73
+ if (xx(3) /= "jlm") error stop 74
+ if (yy(5) /= "def") error stop 72
+ if (yy(6) /= "ghi") error stop 73
+ if (yy(7) /= "jlm") error stop 74
+ if (zz(-k) /= "def") error stop 72
+ if (zz(-k+1) /= "ghi") error stop 73
+ if (zz(-k+2) /= "jlm") error stop 74
+ else
+ error stop 78
+ endif
+ xx(1) = "ABC"
+ xx(2) = "DEF"
+ xx(3) = "GHI"
+ yy(5) = "ABC"
+ yy(6) = "DEF"
+ yy(7) = "GHI"
+ zz(-k) = "ABC"
+ zz(-k+1) = "DEF"
+ zz(-k+2) = "GHI"
+ res%x = get_loc(xx)
+ res%y = get_loc(yy)
+ res%z = get_loc(zz)
+contains
+ integer (c_intptr_t) function get_loc (arg)
+ character(len=*), target :: arg(:)
+ ! %loc does copy in/out if not simply contiguous
+ ! extra func needed because of 'target' attribute
+ get_loc = transfer (c_loc(arg), res%x)
+ end
+end
+
+type(loc_t) function char_assumed_shape_in_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*), optional :: xx(:)
+ character(len=3), optional :: yy(5:)
+ character(len=k), optional :: zz(-k:)
+ intent(in) :: xx, yy, zz
+ if (num == 3) then
+ if (present (xx) .or. present (yy) .or. present (zz)) error stop 1
+ res%x = -1; res%y = -1; res%z = -1
+ return
+ end if
+ if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1
+ print *, xx(1:3)
+ if (3 /= size(xx)) error stop 80
+ if (3 /= size(yy)) error stop 80
+ if (3 /= size(zz)) error stop 80
+ if (3 /= len(xx)) error stop 81
+ if (3 /= len(yy)) error stop 81
+ if (3 /= len(zz)) error stop 81
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (5 /= lbound(yy, dim=1)) stop 49
+ if (-k /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (7 /= ubound(yy, dim=1)) stop 49
+ if (-k+2 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (is_contiguous (xx)) error stop 89
+ if (is_contiguous (yy)) error stop 89
+ if (is_contiguous (zz)) error stop 89
+ if (xx(1) /= "abc") error stop 82
+ if (xx(2) /= "ghi") error stop 83
+ if (xx(3) /= "nop") error stop 84
+ if (yy(5) /= "abc") error stop 82
+ if (yy(6) /= "ghi") error stop 83
+ if (yy(7) /= "nop") error stop 84
+ if (zz(-k) /= "abc") error stop 82
+ if (zz(-k+1) /= "ghi") error stop 83
+ if (zz(-k+2) /= "nop") error stop 84
+ else if (num == 2) then
+ if (.not.is_contiguous (xx)) error stop 89
+ if (.not.is_contiguous (yy)) error stop 89
+ if (.not.is_contiguous (zz)) error stop 89
+ if (xx(1) /= "def") error stop 85
+ if (xx(2) /= "ghi") error stop 86
+ if (xx(3) /= "jlm") error stop 87
+ if (yy(5) /= "def") error stop 85
+ if (yy(6) /= "ghi") error stop 86
+ if (yy(7) /= "jlm") error stop 87
+ if (zz(-k) /= "def") error stop 85
+ if (zz(-k+1) /= "ghi") error stop 86
+ if (zz(-k+2) /= "jlm") error stop 87
+ else
+ error stop 88
+ endif
+ res%x = get_loc(xx)
+ res%y = get_loc(yy)
+ res%z = get_loc(zz)
+contains
+ integer (c_intptr_t) function get_loc (arg)
+ character(len=*), target :: arg(:)
+ ! %loc does copy in/out if not simply contiguous
+ ! extra func needed because of 'target' attribute
+ get_loc = transfer (c_loc(arg), res%x)
+ end
+end
+
+
+
+type(loc_t) function char_assumed_shape_cont_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*), optional :: xx(:)
+ character(len=3), optional :: yy(5:)
+ character(len=k), optional :: zz(-k:)
+ contiguous :: xx, yy, zz
+ if (num == 3) then
+ if (present (xx) .or. present (yy) .or. present (zz)) error stop 1
+ res%x = -1; res%y = -1; res%z = -1
+ return
+ end if
+ if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 90
+ if (3 /= len(yy)) error stop 90
+ if (3 /= len(zz)) error stop 90
+ if (3 /= size(xx)) error stop 91
+ if (3 /= size(yy)) error stop 91
+ if (3 /= size(zz)) error stop 91
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (5 /= lbound(yy, dim=1)) stop 49
+ if (-k /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (7 /= ubound(yy, dim=1)) stop 49
+ if (-k+2 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 92
+ if (xx(2) /= "ghi") error stop 93
+ if (xx(3) /= "nop") error stop 94
+ if (yy(5) /= "abc") error stop 92
+ if (yy(6) /= "ghi") error stop 93
+ if (yy(7) /= "nop") error stop 94
+ if (zz(-k) /= "abc") error stop 92
+ if (zz(-k+1) /= "ghi") error stop 93
+ if (zz(-k+2) /= "nop") error stop 94
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 92
+ if (xx(2) /= "ghi") error stop 93
+ if (xx(3) /= "jlm") error stop 94
+ if (yy(5) /= "def") error stop 92
+ if (yy(6) /= "ghi") error stop 93
+ if (yy(7) /= "jlm") error stop 94
+ if (zz(-k) /= "def") error stop 92
+ if (zz(-k+1) /= "ghi") error stop 93
+ if (zz(-k+2) /= "jlm") error stop 94
+ else
+ error stop 98
+ endif
+ xx(1) = "ABC"
+ xx(2) = "DEF"
+ xx(3) = "GHI"
+ yy(5) = "ABC"
+ yy(6) = "DEF"
+ yy(7) = "GHI"
+ zz(-k) = "ABC"
+ zz(-k+1) = "DEF"
+ zz(-k+2) = "GHI"
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+type(loc_t) function char_assumed_shape_cont_in_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(len=*), optional :: xx(:)
+ character(len=3), optional :: yy(5:)
+ character(len=k), optional :: zz(-k:)
+ intent(in) :: xx, yy, zz
+ contiguous :: xx, yy, zz
+ if (num == 3) then
+ if (present (xx) .or. present (yy) .or. present (zz)) error stop 1
+ res%x = -1; res%y = -1; res%z = -1
+ return
+ end if
+ if (.not.present (xx) .or. .not.present (yy) .or. .not.present (zz)) error stop 1
+ print *, xx(1:3)
+ if (3 /= size(xx)) error stop 100
+ if (3 /= size(yy)) error stop 100
+ if (3 /= size(zz)) error stop 100
+ if (3 /= len(xx)) error stop 101
+ if (3 /= len(yy)) error stop 101
+ if (3 /= len(zz)) error stop 101
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (5 /= lbound(yy, dim=1)) stop 49
+ if (-k /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (7 /= ubound(yy, dim=1)) stop 49
+ if (-k+2 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (xx(1) /= "abc") error stop 102
+ if (xx(2) /= "ghi") error stop 103
+ if (xx(3) /= "nop") error stop 104
+ if (yy(5) /= "abc") error stop 102
+ if (yy(6) /= "ghi") error stop 103
+ if (yy(7) /= "nop") error stop 104
+ if (zz(-k) /= "abc") error stop 102
+ if (zz(-k+1) /= "ghi") error stop 103
+ if (zz(-k+2) /= "nop") error stop 104
+ else if (num == 2) then
+ if (xx(1) /= "def") error stop 105
+ if (xx(2) /= "ghi") error stop 106
+ if (xx(3) /= "jlm") error stop 107
+ if (yy(5) /= "def") error stop 105
+ if (yy(6) /= "ghi") error stop 106
+ if (yy(7) /= "jlm") error stop 107
+ if (zz(-k) /= "def") error stop 105
+ if (zz(-k+1) /= "ghi") error stop 106
+ if (zz(-k+2) /= "jlm") error stop 107
+ else
+ error stop 108
+ endif
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+end module
+
+
+use m
+implicit none (type, external)
+character(len=3) :: a(6), a2(6), a3(6), a_init(6)
+type(loc_t) :: loc3
+
+a_init = ['abc', 'def', 'ghi', 'jlm', 'nop', 'qrs']
+
+! -- Fortran: assumed size
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+loc3 = char_assumed_size_f (n=size(a(2:4)), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+loc3 = char_assumed_size_in_f (n=size(a(2:4)), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+! -- Fortran: explicit shape
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+loc3 = char_expl_size_f (n=size(a(2:4)), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+loc3 = char_expl_size_in_f (n=size(a(::2)), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+! -- Fortran: assumed rank
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_f (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+loc3 = char_assumed_rank_f (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_in_f (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+loc3 = char_assumed_rank_in_f (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+! -- Fortran: assumed rank contiguous
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+loc3 = char_assumed_rank_cont_f (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+loc3 = char_assumed_rank_cont_in_f (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+! -- Fortran: assumed shape
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_f (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+loc3 = char_assumed_shape_f (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_in_f (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+loc3 = char_assumed_shape_in_f (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+! -- Fortran: assumed shape contiguous
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+loc3 = char_assumed_shape_cont_f (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+loc3 = char_assumed_shape_cont_in_f (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+
+! --- character - call C directly --
+
+! -- C: assumed size
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+loc3 = char_assumed_size_c (n=size(a(2:4)), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+loc3 = char_assumed_size_in_c (n=size(a(2:4)), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+! -- C: explicit shape
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+loc3 = char_expl_size_c (n=size(a(::2)), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+loc3 = char_expl_size_in_c (n=size(a(::2)), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+! -- C: assumed rank
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_c (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+loc3 = char_assumed_rank_c (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_in_c (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+loc3 = char_assumed_rank_in_c (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+! -- C: assumed rank contiguous
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+loc3 = char_assumed_rank_cont_c (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+loc3 = char_assumed_rank_cont_in_c (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+! -- C: assumed shape
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_c (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+loc3 = char_assumed_shape_c (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_in_c (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+loc3 = char_assumed_shape_in_c (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+! -- C: assumed shape contiguous
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a2 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+if (any (a3 /= ['ABC', 'def', 'DEF', 'jlm', 'GHI', 'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a2 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+if (any (a3 /= ['abc', 'ABC', 'DEF', 'GHI', 'nop', 'qrs'])) error stop 54
+
+loc3 = char_assumed_shape_cont_c (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+loc3 = char_assumed_shape_cont_in_c (k=len(a), num=3)
+if (loc3%x /= -1 .or. loc3%y /= -1 .or. loc3%z /= -1) error stop 2
+end
+
+! { dg-output "At line 1003 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1003 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1003 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1024 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1024 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1024 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1046 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1046 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1046 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1067 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1067 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1067 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1132 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1132 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1132 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1153 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1153 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1153 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1218 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1218 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1218 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1239 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1239 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1239 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1264 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1264 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1264 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1285 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1285 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1285 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1307 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1307 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1307 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1328 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1328 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1328 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1393 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1393 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1393 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1414 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1414 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1414 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1479 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1479 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1479 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1500 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1500 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1500 of file .*bind-c-contiguous-4.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.c b/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.c
new file mode 100644
index 00000000000..48c03d4e02e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.c
@@ -0,0 +1,345 @@
+#include <ISO_Fortran_binding.h>
+#include <stdbool.h>
+#include <string.h>
+
+struct loc_t {
+ intptr_t x, y, z;
+};
+
+typedef struct loc_t (*ftn_fn) (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_size_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_size_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_expl_size_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_expl_size_in_f (CFI_cdesc_t *,CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_rank_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_rank_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_rank_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_rank_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_shape_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_shape_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_shape_cont_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+struct loc_t char_assumed_shape_cont_in_f (CFI_cdesc_t *, CFI_cdesc_t *, CFI_cdesc_t *, int, int);
+
+static void
+basic_check(CFI_cdesc_t *x, bool is_cont)
+{
+ if (!x->base_addr)
+ __builtin_abort ();
+ if (x->elem_len != 3*(4*sizeof(char))) /* ucs4_char */
+ __builtin_abort ();
+ if (x->version != CFI_VERSION)
+ __builtin_abort ();
+ if (x->rank != 1)
+ __builtin_abort ();
+ if (x->attribute != CFI_attribute_other)
+ __builtin_abort ();
+ if (x->type != CFI_type_ucs4_char)
+ __builtin_abort ();
+ if (x->dim[0].lower_bound != 0)
+ __builtin_abort ();
+ if (x->dim[0].extent != 3)
+ __builtin_abort ();
+ if (CFI_is_contiguous (x) != (x->elem_len == x->dim[0].sm))
+ __builtin_abort ();
+ if (is_cont != CFI_is_contiguous (x))
+ __builtin_abort ();
+}
+
+static void
+print_str (void *p, size_t len)
+{
+ __builtin_printf ("DEBUG: >");
+ /* Use ' ' for '\0' */
+ for (size_t i = 0; i < len*4; ++i)
+ __builtin_printf ("%c", ((const char*) p)[i] ? ((const char*) p)[i] : ' ');
+ __builtin_printf ("<\n");
+}
+
+static void
+check_str (CFI_cdesc_t *x, const char *str, size_t n, const CFI_index_t subscripts[])
+{
+ /* Avoid checking for '\0'. */
+ if (memcmp ((const char*) CFI_address (x, subscripts), str, n) != 0)
+ __builtin_abort ();
+}
+
+static void
+set_str (CFI_cdesc_t *x, const char *str, size_t n, const CFI_index_t subscripts[])
+{
+ char *p = CFI_address (x, subscripts);
+ if (x->elem_len != n)
+ __builtin_abort ();
+ for (size_t i = 0; i < n; ++i)
+ p[i] = str[i];
+}
+
+static struct loc_t
+do_call (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num, bool intent_in, ftn_fn fn, bool is_cont, bool fort_cont)
+{
+ const CFI_index_t zero[1] = { 0 };
+ const CFI_index_t one[1] = { 1 };
+ const CFI_index_t two[1] = { 2 };
+ struct loc_t addr1, addr2;
+ if (k != 3)
+ __builtin_abort ();
+ basic_check (x, is_cont || num == 2);
+ basic_check (y, is_cont || num == 2);
+ basic_check (z, is_cont || num == 2);
+ if (!is_cont && num == 1)
+ {
+ check_str (x, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero);
+ check_str (x, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one);
+ check_str (x, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two);
+ check_str (y, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero);
+ check_str (y, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one);
+ check_str (y, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two);
+ check_str (z, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero);
+ check_str (z, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one);
+ check_str (z, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two);
+ }
+ else if (num == 1)
+ {
+ if (memcmp ((const char*) x->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0)
+ __builtin_abort ();
+ if (memcmp ((const char*) y->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0)
+ __builtin_abort ();
+ if (memcmp ((const char*) z->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0)
+ __builtin_abort ();
+ }
+ else if (num == 2)
+ {
+ if (memcmp ((const char*) x->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9*4) != 0)
+ __builtin_abort ();
+ if (memcmp ((const char*) y->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9*4) != 0)
+ __builtin_abort ();
+ if (memcmp ((const char*) z->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9*4) != 0)
+ __builtin_abort ();
+ }
+ else
+ __builtin_abort ();
+ addr1.x = (intptr_t) x->base_addr;
+ addr1.y = (intptr_t) y->base_addr;
+ addr1.z = (intptr_t) z->base_addr;
+ addr2 = fn (x, y, z, 3, num);
+ if (!CFI_is_contiguous (x) && fort_cont)
+ {
+ /* Check for callee copy in/copy out. */
+ if (addr1.x == addr2.x || addr1.x != (intptr_t) x->base_addr)
+ __builtin_abort ();
+ if (addr1.y == addr2.y || addr1.y != (intptr_t) y->base_addr)
+ __builtin_abort ();
+ if (addr1.z == addr2.z || addr1.z != (intptr_t) z->base_addr)
+ __builtin_abort ();
+ }
+ else
+ {
+ if (addr1.x != addr2.x || addr1.x != (intptr_t) x->base_addr)
+ __builtin_abort ();
+ if (addr1.y != addr2.y || addr1.y != (intptr_t) y->base_addr)
+ __builtin_abort ();
+ if (addr1.z != addr2.z || addr1.z != (intptr_t) z->base_addr)
+ __builtin_abort ();
+ }
+ // intent_in
+ if (intent_in && !is_cont && num == 1)
+ {
+ check_str (x, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero);
+ check_str (x, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one);
+ check_str (x, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two);
+ check_str (y, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero);
+ check_str (y, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one);
+ check_str (y, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two);
+ check_str (z, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero);
+ check_str (z, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one);
+ check_str (z, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two);
+ }
+ else if (intent_in && num == 1)
+ {
+ if (memcmp ((const char*) x->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0)
+ __builtin_abort ();
+ if (memcmp ((const char*) y->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0)
+ __builtin_abort ();
+ if (memcmp ((const char*) z->base_addr, "a\0\0\0b\0\0\0c\0\0\0g\0\0\0h\0\0\0i\0\0\0n\0\0\0o\0\0\0p\0\0\0", 9*4) != 0)
+ __builtin_abort ();
+ }
+ else if (intent_in && num == 2)
+ {
+ if (memcmp ((const char*) x->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9) != 0)
+ __builtin_abort ();
+ if (memcmp ((const char*) y->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9) != 0)
+ __builtin_abort ();
+ if (memcmp ((const char*) z->base_addr, "d\0\0\0e\0\0\0f\0\0\0g\0\0\0h\0\0\0i\0\0\0j\0\0\0l\0\0\0m\0\0\0", 9) != 0)
+ __builtin_abort ();
+ }
+ else if (intent_in)
+ __builtin_abort ();
+ if (intent_in)
+ {
+ if (is_cont && num == 1)
+ {
+ /* Copy in - set the value to check that no copy out is done. */
+ memcpy ((char*) x->base_addr, "1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9\0\0\0", 9*4);
+ memcpy ((char*) y->base_addr, "1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9\0\0\0", 9*4);
+ memcpy ((char*) z->base_addr, "1\0\0\0""2\0\0\0""3\0\0\0""4\0\0\0""5\0\0\0""6\0\0\0""7\0\0\0""8\0\0\0""9\0\0\0", 9*4);
+ }
+ return addr1;
+ }
+ // !intent_in
+ if (!is_cont && num == 1)
+ {
+ check_str (x, "A\0\0\0B\0\0\0C\0\0\0", 3*4, zero);
+ check_str (x, "D\0\0\0E\0\0\0F\0\0\0", 3*4, one);
+ check_str (x, "G\0\0\0H\0\0\0I\0\0\0", 3*4, two);
+ check_str (y, "A\0\0\0B\0\0\0C\0\0\0", 3*4, zero);
+ check_str (y, "D\0\0\0E\0\0\0F\0\0\0", 3*4, one);
+ check_str (y, "G\0\0\0H\0\0\0I\0\0\0", 3*4, two);
+ check_str (z, "A\0\0\0B\0\0\0C\0\0\0", 3*4, zero);
+ check_str (z, "D\0\0\0E\0\0\0F\0\0\0", 3*4, one);
+ check_str (z, "G\0\0\0H\0\0\0I\0\0\0", 3*4, two);
+ }
+ else
+ {
+ if (memcmp ((const char*) x->base_addr, "A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I\0\0\0", 9*4) != 0)
+ __builtin_abort ();
+ if (memcmp ((const char*) y->base_addr, "A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I\0\0\0", 9*4) != 0)
+ __builtin_abort ();
+ if (memcmp ((const char*) z->base_addr, "A\0\0\0B\0\0\0C\0\0\0D\0\0\0E\0\0\0F\0\0\0G\0\0\0H\0\0\0I\0\0\0", 9*4) != 0)
+ __builtin_abort ();
+ }
+ return addr1;
+}
+
+struct loc_t
+char_assumed_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_assumed_size_f, true, false);
+}
+
+struct loc_t
+char_assumed_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_size_in_f, true, false);
+}
+
+struct loc_t
+char_expl_size_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_expl_size_f, true, false);
+}
+
+struct loc_t
+char_expl_size_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_expl_size_in_f, true, false);
+}
+
+struct loc_t
+char_assumed_rank_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_assumed_rank_f, false, false);
+}
+
+struct loc_t
+char_assumed_rank_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_rank_in_f, false, false);
+}
+
+struct loc_t
+char_assumed_rank_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, true, false);
+}
+
+struct loc_t
+char_assumed_rank_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, true, false);
+}
+
+static void
+reset_var (CFI_cdesc_t *x, int num)
+{
+ const CFI_index_t zero[1] = { 0 };
+ const CFI_index_t one[1] = { 1 };
+ const CFI_index_t two[1] = { 2 };
+
+ if (num == 1)
+ {
+ set_str (x, "a\0\0\0b\0\0\0c\0\0\0", 3*4, zero);
+ set_str (x, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one);
+ set_str (x, "n\0\0\0o\0\0\0p\0\0\0", 3*4, two);
+ }
+ else if (num == 2)
+ {
+ set_str (x, "d\0\0\0e\0\0\0f\0\0\0", 3*4, zero);
+ set_str (x, "g\0\0\0h\0\0\0i\0\0\0", 3*4, one);
+ set_str (x, "j\0\0\0l\0\0\0m\0\0\0", 3*4, two);
+ }
+ else
+ __builtin_abort ();
+}
+
+static void
+reset_vars (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z, int num)
+{
+ reset_var (x, num);
+ reset_var (y, num);
+ reset_var (z, num);
+}
+
+struct loc_t
+char_assumed_shape_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ /* Make use of having a noncontiguous argument to check that the callee
+ handles noncontiguous variables. */
+ do_call (x, y, z, k, num, false, char_assumed_size_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, true, char_assumed_size_in_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, false, char_expl_size_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, true, char_expl_size_in_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, false, char_assumed_rank_cont_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, true, char_assumed_rank_cont_in_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, false, true);
+ reset_vars (x, y, z, num);
+ do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, false, true);
+ /* Actual func call. */
+ reset_vars (x, y, z, num);
+ return do_call (x, y, z, k, num, false, char_assumed_shape_f, false, false);
+}
+
+struct loc_t
+char_assumed_shape_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_shape_in_f, false, false);
+}
+
+struct loc_t
+char_assumed_shape_cont_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, false, char_assumed_shape_cont_f, true, false);
+}
+
+struct loc_t
+char_assumed_shape_cont_in_c (CFI_cdesc_t *x, CFI_cdesc_t *y, CFI_cdesc_t *z,
+ int k, int num)
+{
+ return do_call (x, y, z, k, num, true, char_assumed_shape_cont_in_f, true, false);
+}
diff --git a/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.f90 b/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.f90
new file mode 100644
index 00000000000..3eb2732a368
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/bind-c-contiguous-5.f90
@@ -0,0 +1,1574 @@
+! { dg-do run }
+! { dg-additional-sources bind-c-contiguous-5.c }
+! { dg-additional-options "-fcheck=all" }
+! { dg-prune-output "command-line option '-fcheck=.*' is valid for Fortran but not for C" }
+! ---- Same as bind-c-contiguous-1.f90 - but with kind=4 characters
+! Fortran demands that with bind(C), the callee ensure that for
+! * 'contiguous'
+! * len=* with explicit/assumed-size arrays
+! noncontiguous actual arguments are handled.
+! (in without bind(C) in gfortran, caller handles the copy in/out
+
+! Additionally, for a bind(C) callee, a Fortran-written caller
+! has to ensure the same (for contiguous + len=* to explicit-/assumed-size arrays)
+
+module m
+ use iso_c_binding, only: c_intptr_t, c_bool, c_loc, c_int
+ implicit none (type, external)
+
+ type, bind(C) :: loc_t
+ integer(c_intptr_t) :: x, y, z
+ end type loc_t
+
+interface
+ type(loc_t) function char_assumed_size_c (xx, yy, zz, n, num) bind(C)
+ import :: loc_t, c_bool, c_int
+ integer(c_int), value :: n, num
+ character(kind=4, len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
+ end function
+
+ type(loc_t) function char_assumed_size_in_c (xx, yy, zz, n, num) bind(C)
+ import :: loc_t, c_bool, c_int
+ integer(c_int), value :: n, num
+ character(kind=4, len=*), intent(in) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
+ end function
+
+ type(loc_t) function char_expl_size_c (xx, yy, zz, n, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer(c_int), value :: n, num
+ character(kind=4, len=*) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3)
+ end function
+
+ type(loc_t) function char_expl_size_in_c (xx, yy, zz, n, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer(c_int), value :: n, num
+ character(kind=4, len=*), intent(in) :: xx(n), yy(n:n+3), zz(6:6, 3:n, 3:n+3)
+ end function
+
+ type(loc_t) function char_assumed_rank_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(kind=4, len=*) :: xx(..)
+ character(kind=4, len=3) :: yy(..)
+ character(kind=4, len=k) :: zz(..)
+ end function
+
+ type(loc_t) function char_assumed_rank_in_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(kind=4, len=*), intent(in) :: xx(..)
+ character(kind=4, len=3), intent(in) :: yy(..)
+ character(kind=4, len=k), intent(in) :: zz(..)
+ end function
+
+ type(loc_t) function char_assumed_rank_cont_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(kind=4, len=*), contiguous :: xx(..)
+ character(kind=4, len=3), contiguous :: yy(..)
+ character(kind=4, len=k), contiguous :: zz(..)
+ end function
+
+ type(loc_t) function char_assumed_rank_cont_in_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(kind=4, len=*), contiguous, intent(in) :: xx(..)
+ character(kind=4, len=3), contiguous, intent(in) :: yy(..)
+ character(kind=4, len=k), contiguous, intent(in) :: zz(..)
+ end function
+
+ type(loc_t) function char_assumed_shape_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(kind=4, len=*) :: xx(:)
+ character(kind=4, len=3) :: yy(5:)
+ character(kind=4, len=k) :: zz(-k:)
+ end function
+
+ type(loc_t) function char_assumed_shape_in_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(kind=4, len=*), intent(in) :: xx(:)
+ character(kind=4, len=3), intent(in) :: yy(5:)
+ character(kind=4, len=k), intent(in) :: zz(-k:)
+ end function
+
+ type(loc_t) function char_assumed_shape_cont_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(kind=4, len=*), contiguous :: xx(:)
+ character(kind=4, len=3), contiguous :: yy(5:)
+ character(kind=4, len=k), contiguous :: zz(-k:)
+ end function
+
+ type(loc_t) function char_assumed_shape_cont_in_c (xx, yy, zz, k, num) bind(c)
+ import :: loc_t, c_bool, c_int
+ integer, value :: k, num
+ character(kind=4, len=*), contiguous, intent(in) :: xx(:)
+ character(kind=4, len=3), contiguous, intent(in) :: yy(5:)
+ character(kind=4, len=k), contiguous, intent(in) :: zz(-k:)
+ end function
+end interface
+
+contains
+
+type(loc_t) function char_assumed_size_f (xx, yy, zz, n, num) bind(c) result(res)
+ integer, value :: num, n
+ character(kind=4, len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 1
+ if (3 /= len(yy)) error stop 1
+ if (3 /= len(zz)) error stop 1
+ if (1 /= lbound(xx,dim=1)) error stop 1
+ if (3 /= lbound(yy,dim=1)) error stop 1
+ if (6 /= lbound(zz,dim=1)) error stop 1
+ if (3 /= lbound(zz,dim=2)) error stop 1
+ if (3 /= lbound(zz,dim=3)) error stop 1
+ if (1 /= size(zz,dim=1)) error stop 1
+ if (1 /= size(zz,dim=2)) error stop 1
+ if (6 /= ubound(zz,dim=1)) error stop 1
+ if (3 /= ubound(zz,dim=2)) error stop 1
+ if (num == 1) then
+ if (xx(1) /= 4_"abc") error stop 2
+ if (xx(2) /= 4_"ghi") error stop 3
+ if (xx(3) /= 4_"nop") error stop 4
+ if (yy(3) /= 4_"abc") error stop 2
+ if (yy(4) /= 4_"ghi") error stop 3
+ if (yy(5) /= 4_"nop") error stop 4
+ if (zz(6,n,3) /= 4_"abc") error stop 2
+ if (zz(6,n,4) /= 4_"ghi") error stop 3
+ if (zz(6,n,5) /= 4_"nop") error stop 4
+ else if (num == 2) then
+ if (xx(1) /= 4_"def") error stop 2
+ if (xx(2) /= 4_"ghi") error stop 3
+ if (xx(3) /= 4_"jlm") error stop 4
+ if (yy(3) /= 4_"def") error stop 2
+ if (yy(4) /= 4_"ghi") error stop 3
+ if (yy(5) /= 4_"jlm") error stop 4
+ if (zz(6,n,3) /= 4_"def") error stop 2
+ if (zz(6,n,4) /= 4_"ghi") error stop 3
+ if (zz(6,n,5) /= 4_"jlm") error stop 4
+ else
+ error stop 8
+ endif
+ xx(1) = 4_"ABC"
+ xx(2) = 4_"DEF"
+ xx(3) = 4_"GHI"
+ yy(3) = 4_"ABC"
+ yy(4) = 4_"DEF"
+ yy(5) = 4_"GHI"
+ zz(6,n,3) = 4_"ABC"
+ zz(6,n,4) = 4_"DEF"
+ zz(6,n,5) = 4_"GHI"
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+type(loc_t) function char_assumed_size_in_f (xx, yy, zz, n, num) bind(c) result(res)
+ integer, value :: num, n
+ character(kind=4, len=*) :: xx(*), yy(n:*), zz(6:6, 3:n, 3:*)
+ intent(in) :: xx, yy, zz
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 1
+ if (3 /= len(yy)) error stop 1
+ if (3 /= len(zz)) error stop 1
+ if (1 /= lbound(xx,dim=1)) error stop 1
+ if (3 /= lbound(yy,dim=1)) error stop 1
+ if (6 /= lbound(zz,dim=1)) error stop 1
+ if (3 /= lbound(zz,dim=2)) error stop 1
+ if (3 /= lbound(zz,dim=3)) error stop 1
+ if (1 /= size(zz,dim=1)) error stop 1
+ if (1 /= size(zz,dim=2)) error stop 1
+ if (6 /= ubound(zz,dim=1)) error stop 1
+ if (3 /= ubound(zz,dim=2)) error stop 1
+ if (num == 1) then
+ if (xx(1) /= 4_"abc") error stop 2
+ if (xx(2) /= 4_"ghi") error stop 3
+ if (xx(3) /= 4_"nop") error stop 4
+ if (yy(3) /= 4_"abc") error stop 2
+ if (yy(4) /= 4_"ghi") error stop 3
+ if (yy(5) /= 4_"nop") error stop 4
+ if (zz(6,n,3) /= 4_"abc") error stop 2
+ if (zz(6,n,4) /= 4_"ghi") error stop 3
+ if (zz(6,n,5) /= 4_"nop") error stop 4
+ else if (num == 2) then
+ if (xx(1) /= 4_"def") error stop 2
+ if (xx(2) /= 4_"ghi") error stop 3
+ if (xx(3) /= 4_"jlm") error stop 4
+ if (yy(3) /= 4_"def") error stop 2
+ if (yy(4) /= 4_"ghi") error stop 3
+ if (yy(5) /= 4_"jlm") error stop 4
+ if (zz(6,n,3) /= 4_"def") error stop 2
+ if (zz(6,n,4) /= 4_"ghi") error stop 3
+ if (zz(6,n,5) /= 4_"jlm") error stop 4
+ else
+ error stop 8
+ endif
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" } if (num == 1) then
+end
+
+type(loc_t) function char_expl_size_f (xx, yy, zz, n, num) bind(c) result(res)
+ integer, value :: num, n
+ character(kind=4, len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2)
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 1
+ if (3 /= len(yy)) error stop 1
+ if (3 /= len(zz)) error stop 1
+ if (1 /= lbound(xx,dim=1)) error stop 1
+ if (3 /= lbound(yy,dim=1)) error stop 1
+ if (6 /= lbound(zz,dim=1)) error stop 1
+ if (3 /= lbound(zz,dim=2)) error stop 1
+ if (3 /= lbound(zz,dim=3)) error stop 1
+ if (3 /= size(xx,dim=1)) error stop 1
+ if (3 /= size(yy,dim=1)) error stop 1
+ if (1 /= size(zz,dim=1)) error stop 1
+ if (1 /= size(zz,dim=2)) error stop 1
+ if (3 /= size(zz,dim=3)) error stop 1
+ if (3 /= ubound(xx,dim=1)) error stop 1
+ if (5 /= ubound(yy,dim=1)) error stop 1
+ if (6 /= ubound(zz,dim=1)) error stop 1
+ if (3 /= ubound(zz,dim=2)) error stop 1
+ if (5 /= ubound(zz,dim=3)) error stop 1
+ if (num == 1) then
+ if (xx(1) /= 4_"abc") error stop 2
+ if (xx(2) /= 4_"ghi") error stop 3
+ if (xx(3) /= 4_"nop") error stop 4
+ if (yy(3) /= 4_"abc") error stop 2
+ if (yy(4) /= 4_"ghi") error stop 3
+ if (yy(5) /= 4_"nop") error stop 4
+ if (zz(6,n,3) /= 4_"abc") error stop 2
+ if (zz(6,n,4) /= 4_"ghi") error stop 3
+ if (zz(6,n,5) /= 4_"nop") error stop 4
+ else if (num == 2) then
+ if (xx(1) /= 4_"def") error stop 2
+ if (xx(2) /= 4_"ghi") error stop 3
+ if (xx(3) /= 4_"jlm") error stop 4
+ if (yy(3) /= 4_"def") error stop 2
+ if (yy(4) /= 4_"ghi") error stop 3
+ if (yy(5) /= 4_"jlm") error stop 4
+ if (zz(6,n,3) /= 4_"def") error stop 2
+ if (zz(6,n,4) /= 4_"ghi") error stop 3
+ if (zz(6,n,5) /= 4_"jlm") error stop 4
+ else
+ error stop 8
+ endif
+ xx(1) = 4_"ABC"
+ xx(2) = 4_"DEF"
+ xx(3) = 4_"GHI"
+ yy(3) = 4_"ABC"
+ yy(4) = 4_"DEF"
+ yy(5) = 4_"GHI"
+ zz(6,n,3) = 4_"ABC"
+ zz(6,n,4) = 4_"DEF"
+ zz(6,n,5) = 4_"GHI"
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+type(loc_t) function char_expl_size_in_f (xx, yy, zz, n, num) bind(c) result(res)
+ integer, value :: num, n
+ character(kind=4, len=*) :: xx(n), yy(n:n+2), zz(6:6, 3:n, 3:n+2)
+ intent(in) :: xx, yy, zz
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 1
+ if (3 /= len(yy)) error stop 1
+ if (3 /= len(zz)) error stop 1
+ if (1 /= lbound(xx,dim=1)) error stop 1
+ if (3 /= lbound(yy,dim=1)) error stop 1
+ if (6 /= lbound(zz,dim=1)) error stop 1
+ if (3 /= lbound(zz,dim=2)) error stop 1
+ if (3 /= lbound(zz,dim=3)) error stop 1
+ if (3 /= size(xx,dim=1)) error stop 1
+ if (3 /= size(yy,dim=1)) error stop 1
+ if (1 /= size(zz,dim=1)) error stop 1
+ if (1 /= size(zz,dim=2)) error stop 1
+ if (3 /= size(zz,dim=3)) error stop 1
+ if (3 /= ubound(xx,dim=1)) error stop 1
+ if (5 /= ubound(yy,dim=1)) error stop 1
+ if (6 /= ubound(zz,dim=1)) error stop 1
+ if (3 /= ubound(zz,dim=2)) error stop 1
+ if (5 /= ubound(zz,dim=3)) error stop 1
+ if (num == 1) then
+ if (xx(1) /= 4_"abc") error stop 2
+ if (xx(2) /= 4_"ghi") error stop 3
+ if (xx(3) /= 4_"nop") error stop 4
+ if (yy(3) /= 4_"abc") error stop 2
+ if (yy(4) /= 4_"ghi") error stop 3
+ if (yy(5) /= 4_"nop") error stop 4
+ if (zz(6,n,3) /= 4_"abc") error stop 2
+ if (zz(6,n,4) /= 4_"ghi") error stop 3
+ if (zz(6,n,5) /= 4_"nop") error stop 4
+ else if (num == 2) then
+ if (xx(1) /= 4_"def") error stop 2
+ if (xx(2) /= 4_"ghi") error stop 3
+ if (xx(3) /= 4_"jlm") error stop 4
+ if (yy(3) /= 4_"def") error stop 2
+ if (yy(4) /= 4_"ghi") error stop 3
+ if (yy(5) /= 4_"jlm") error stop 4
+ if (zz(6,n,3) /= 4_"def") error stop 2
+ if (zz(6,n,4) /= 4_"ghi") error stop 3
+ if (zz(6,n,5) /= 4_"jlm") error stop 4
+ else
+ error stop 8
+ endif
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+
+type(loc_t) function char_assumed_rank_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(kind=4, len=*) :: xx(..)
+ character(kind=4, len=3) :: yy(..)
+ character(kind=4, len=k) :: zz(..)
+ if (3 /= len(xx)) error stop 40
+ if (3 /= len(yy)) error stop 40
+ if (3 /= len(zz)) error stop 40
+ if (3 /= size(xx)) error stop 41
+ if (3 /= size(yy)) error stop 41
+ if (3 /= size(zz)) error stop 41
+ if (1 /= rank(xx)) error stop 49
+ if (1 /= rank(yy)) error stop 49
+ if (1 /= rank(zz)) error stop 49
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (1 /= lbound(yy, dim=1)) stop 49
+ if (1 /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (3 /= ubound(yy, dim=1)) stop 49
+ if (3 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (is_contiguous (xx)) error stop 49
+ if (is_contiguous (yy)) error stop 49
+ if (is_contiguous (zz)) error stop 49
+ else if (num == 2) then
+ if (.not. is_contiguous (xx)) error stop 49
+ if (.not. is_contiguous (yy)) error stop 49
+ if (.not. is_contiguous (zz)) error stop 49
+ else
+ error stop 48
+ end if
+ select rank (xx)
+ rank (1)
+ print *, xx(1:3)
+ if (num == 1) then
+ if (xx(1) /= 4_"abc") error stop 42
+ if (xx(2) /= 4_"ghi") error stop 43
+ if (xx(3) /= 4_"nop") error stop 44
+ else if (num == 2) then
+ if (xx(1) /= 4_"def") error stop 45
+ if (xx(2) /= 4_"ghi") error stop 46
+ if (xx(3) /= 4_"jlm") error stop 47
+ else
+ error stop 48
+ endif
+ xx(1) = 4_"ABC"
+ xx(2) = 4_"DEF"
+ xx(3) = 4_"GHI"
+ res%x = get_loc (xx)
+ rank default
+ error stop 99
+ end select
+ select rank (yy)
+ rank (1)
+ print *, yy(1:3)
+ if (num == 1) then
+ if (yy(1) /= 4_"abc") error stop 42
+ if (yy(2) /= 4_"ghi") error stop 43
+ if (yy(3) /= 4_"nop") error stop 44
+ else if (num == 2) then
+ if (yy(1) /= 4_"def") error stop 45
+ if (yy(2) /= 4_"ghi") error stop 46
+ if (yy(3) /= 4_"jlm") error stop 47
+ else
+ error stop 48
+ endif
+ yy(1) = 4_"ABC"
+ yy(2) = 4_"DEF"
+ yy(3) = 4_"GHI"
+ res%y = get_loc (yy)
+ rank default
+ error stop 99
+ end select
+ select rank (zz)
+ rank (1)
+ print *, zz(1:3)
+ if (num == 1) then
+ if (zz(1) /= 4_"abc") error stop 42
+ if (zz(2) /= 4_"ghi") error stop 43
+ if (zz(3) /= 4_"nop") error stop 44
+ else if (num == 2) then
+ if (zz(1) /= 4_"def") error stop 45
+ if (zz(2) /= 4_"ghi") error stop 46
+ if (zz(3) /= 4_"jlm") error stop 47
+ else
+ error stop 48
+ endif
+ zz(1) = 4_"ABC"
+ zz(2) = 4_"DEF"
+ zz(3) = 4_"GHI"
+ res%z = get_loc (zz)
+ rank default
+ error stop 99
+ end select
+contains
+ integer (c_intptr_t) function get_loc (arg)
+ character(kind=4, len=*), target :: arg(:)
+ ! %loc does copy in/out if not simply contiguous
+ ! extra func needed because of 'target' attribute
+ get_loc = transfer (c_loc(arg), res%x)
+ end
+end
+
+type(loc_t) function char_assumed_rank_in_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(kind=4, len=*) :: xx(..)
+ character(kind=4, len=3) :: yy(..)
+ character(kind=4, len=k) :: zz(..)
+ intent(in) :: xx, yy, zz
+ if (3 /= size(yy)) error stop 50
+ if (3 /= len(yy)) error stop 51
+ if (1 /= rank(yy)) error stop 59
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (1 /= lbound(yy, dim=1)) stop 49
+ if (1 /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (3 /= ubound(yy, dim=1)) stop 49
+ if (3 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (is_contiguous (xx)) error stop 59
+ if (is_contiguous (yy)) error stop 59
+ if (is_contiguous (zz)) error stop 59
+ else if (num == 2) then
+ if (.not. is_contiguous (xx)) error stop 59
+ if (.not. is_contiguous (yy)) error stop 59
+ if (.not. is_contiguous (zz)) error stop 59
+ else
+ error stop 48
+ end if
+ select rank (xx)
+ rank (1)
+ print *, xx(1:3)
+ if (num == 1) then
+ if (xx(1) /= 4_"abc") error stop 52
+ if (xx(2) /= 4_"ghi") error stop 53
+ if (xx(3) /= 4_"nop") error stop 54
+ else if (num == 2) then
+ if (xx(1) /= 4_"def") error stop 55
+ if (xx(2) /= 4_"ghi") error stop 56
+ if (xx(3) /= 4_"jlm") error stop 57
+ else
+ error stop 58
+ endif
+ res%x = get_loc(xx)
+ rank default
+ error stop 99
+ end select
+ select rank (yy)
+ rank (1)
+ print *, yy(1:3)
+ if (num == 1) then
+ if (yy(1) /= 4_"abc") error stop 52
+ if (yy(2) /= 4_"ghi") error stop 53
+ if (yy(3) /= 4_"nop") error stop 54
+ else if (num == 2) then
+ if (yy(1) /= 4_"def") error stop 55
+ if (yy(2) /= 4_"ghi") error stop 56
+ if (yy(3) /= 4_"jlm") error stop 57
+ else
+ error stop 58
+ endif
+ res%y = get_loc(yy)
+ rank default
+ error stop 99
+ end select
+ select rank (zz)
+ rank (1)
+ print *, zz(1:3)
+ if (num == 1) then
+ if (zz(1) /= 4_"abc") error stop 52
+ if (zz(2) /= 4_"ghi") error stop 53
+ if (zz(3) /= 4_"nop") error stop 54
+ else if (num == 2) then
+ if (zz(1) /= 4_"def") error stop 55
+ if (zz(2) /= 4_"ghi") error stop 56
+ if (zz(3) /= 4_"jlm") error stop 57
+ else
+ error stop 58
+ endif
+ res%z = get_loc(zz)
+ rank default
+ error stop 99
+ end select
+contains
+ integer (c_intptr_t) function get_loc (arg)
+ character(kind=4, len=*), target :: arg(:)
+ ! %loc does copy in/out if not simply contiguous
+ ! extra func needed because of 'target' attribute
+ get_loc = transfer (c_loc(arg), res%x)
+ end
+end
+
+
+
+type(loc_t) function char_assumed_rank_cont_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(kind=4, len=*) :: xx(..)
+ character(kind=4, len=3) :: yy(..)
+ character(kind=4, len=k) :: zz(..)
+ contiguous :: xx, yy, zz
+ if (3 /= len(xx)) error stop 60
+ if (3 /= len(yy)) error stop 60
+ if (3 /= len(zz)) error stop 60
+ if (3 /= size(xx)) error stop 61
+ if (3 /= size(yy)) error stop 61
+ if (3 /= size(zz)) error stop 61
+ if (1 /= rank(xx)) error stop 69
+ if (1 /= rank(yy)) error stop 69
+ if (1 /= rank(zz)) error stop 69
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (1 /= lbound(yy, dim=1)) stop 49
+ if (1 /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (3 /= ubound(yy, dim=1)) stop 49
+ if (3 /= ubound(zz, dim=1)) stop 49
+ select rank (xx)
+ rank (1)
+ print *, xx(1:3)
+ if (num == 1) then
+ if (xx(1) /= 4_"abc") error stop 62
+ if (xx(2) /= 4_"ghi") error stop 63
+ if (xx(3) /= 4_"nop") error stop 64
+ else if (num == 2) then
+ if (xx(1) /= 4_"def") error stop 65
+ if (xx(2) /= 4_"ghi") error stop 66
+ if (xx(3) /= 4_"jlm") error stop 67
+ else
+ error stop 68
+ endif
+ xx(1) = 4_"ABC"
+ xx(2) = 4_"DEF"
+ xx(3) = 4_"GHI"
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+ select rank (yy)
+ rank (1)
+ print *, yy(1:3)
+ if (num == 1) then
+ if (yy(1) /= 4_"abc") error stop 62
+ if (yy(2) /= 4_"ghi") error stop 63
+ if (yy(3) /= 4_"nop") error stop 64
+ else if (num == 2) then
+ if (yy(1) /= 4_"def") error stop 65
+ if (yy(2) /= 4_"ghi") error stop 66
+ if (yy(3) /= 4_"jlm") error stop 67
+ else
+ error stop 68
+ endif
+ yy(1) = 4_"ABC"
+ yy(2) = 4_"DEF"
+ yy(3) = 4_"GHI"
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+ select rank (zz)
+ rank (1)
+ print *, zz(1:3)
+ if (num == 1) then
+ if (zz(1) /= 4_"abc") error stop 62
+ if (zz(2) /= 4_"ghi") error stop 63
+ if (zz(3) /= 4_"nop") error stop 64
+ else if (num == 2) then
+ if (zz(1) /= 4_"def") error stop 65
+ if (zz(2) /= 4_"ghi") error stop 66
+ if (zz(3) /= 4_"jlm") error stop 67
+ else
+ error stop 68
+ endif
+ zz(1) = 4_"ABC"
+ zz(2) = 4_"DEF"
+ zz(3) = 4_"GHI"
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+end
+
+type(loc_t) function char_assumed_rank_cont_in_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(kind=4, len=*) :: xx(..)
+ character(kind=4, len=3) :: yy(..)
+ character(kind=4, len=k) :: zz(..)
+ intent(in) :: xx, yy, zz
+ contiguous :: xx, yy, zz
+ if (3 /= size(xx)) error stop 30
+ if (3 /= size(yy)) error stop 30
+ if (3 /= size(zz)) error stop 30
+ if (3 /= len(xx)) error stop 31
+ if (3 /= len(yy)) error stop 31
+ if (3 /= len(zz)) error stop 31
+ if (1 /= rank(xx)) error stop 69
+ if (1 /= rank(yy)) error stop 69
+ if (1 /= rank(zz)) error stop 69
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (1 /= lbound(yy, dim=1)) stop 49
+ if (1 /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (3 /= ubound(yy, dim=1)) stop 49
+ if (3 /= ubound(zz, dim=1)) stop 49
+ select rank (xx)
+ rank (1)
+ print *, xx(1:3)
+ if (num == 1) then
+ if (xx(1) /= 4_"abc") error stop 62
+ if (xx(2) /= 4_"ghi") error stop 63
+ if (xx(3) /= 4_"nop") error stop 64
+ else if (num == 2) then
+ if (xx(1) /= 4_"def") error stop 65
+ if (xx(2) /= 4_"ghi") error stop 66
+ if (xx(3) /= 4_"jlm") error stop 67
+ else
+ error stop 68
+ endif
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+ select rank (yy)
+ rank (1)
+ print *, yy(1:3)
+ if (num == 1) then
+ if (yy(1) /= 4_"abc") error stop 62
+ if (yy(2) /= 4_"ghi") error stop 63
+ if (yy(3) /= 4_"nop") error stop 64
+ else if (num == 2) then
+ if (yy(1) /= 4_"def") error stop 65
+ if (yy(2) /= 4_"ghi") error stop 66
+ if (yy(3) /= 4_"jlm") error stop 67
+ else
+ error stop 68
+ endif
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+ select rank (zz)
+ rank (1)
+ print *, zz(1:3)
+ if (num == 1) then
+ if (zz(1) /= 4_"abc") error stop 62
+ if (zz(2) /= 4_"ghi") error stop 63
+ if (zz(3) /= 4_"nop") error stop 64
+ else if (num == 2) then
+ if (zz(1) /= 4_"def") error stop 65
+ if (zz(2) /= 4_"ghi") error stop 66
+ if (zz(3) /= 4_"jlm") error stop 67
+ else
+ error stop 68
+ endif
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+ rank default
+ error stop 99
+ end select
+end
+
+type(loc_t) function char_assumed_shape_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(kind=4, len=*) :: xx(:)
+ character(kind=4, len=3) :: yy(5:)
+ character(kind=4, len=k) :: zz(-k:)
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 70
+ if (3 /= len(yy)) error stop 70
+ if (3 /= len(zz)) error stop 70
+ if (3 /= size(xx)) error stop 71
+ if (3 /= size(yy)) error stop 71
+ if (3 /= size(zz)) error stop 71
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (5 /= lbound(yy, dim=1)) stop 49
+ if (-k /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (7 /= ubound(yy, dim=1)) stop 49
+ if (-k+2 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (is_contiguous (xx)) error stop 79
+ if (is_contiguous (yy)) error stop 79
+ if (is_contiguous (zz)) error stop 79
+ if (xx(1) /= 4_"abc") error stop 72
+ if (xx(2) /= 4_"ghi") error stop 73
+ if (xx(3) /= 4_"nop") error stop 74
+ if (yy(5) /= 4_"abc") error stop 72
+ if (yy(6) /= 4_"ghi") error stop 73
+ if (yy(7) /= 4_"nop") error stop 74
+ if (zz(-k) /= 4_"abc") error stop 72
+ if (zz(-k+1) /= 4_"ghi") error stop 73
+ if (zz(-k+2) /= 4_"nop") error stop 74
+ else if (num == 2) then
+ if (.not.is_contiguous (xx)) error stop 79
+ if (.not.is_contiguous (yy)) error stop 79
+ if (.not.is_contiguous (zz)) error stop 79
+ if (xx(1) /= 4_"def") error stop 72
+ if (xx(2) /= 4_"ghi") error stop 73
+ if (xx(3) /= 4_"jlm") error stop 74
+ if (yy(5) /= 4_"def") error stop 72
+ if (yy(6) /= 4_"ghi") error stop 73
+ if (yy(7) /= 4_"jlm") error stop 74
+ if (zz(-k) /= 4_"def") error stop 72
+ if (zz(-k+1) /= 4_"ghi") error stop 73
+ if (zz(-k+2) /= 4_"jlm") error stop 74
+ else
+ error stop 78
+ endif
+ xx(1) = 4_"ABC"
+ xx(2) = 4_"DEF"
+ xx(3) = 4_"GHI"
+ yy(5) = 4_"ABC"
+ yy(6) = 4_"DEF"
+ yy(7) = 4_"GHI"
+ zz(-k) = 4_"ABC"
+ zz(-k+1) = 4_"DEF"
+ zz(-k+2) = 4_"GHI"
+ res%x = get_loc(xx)
+ res%y = get_loc(yy)
+ res%z = get_loc(zz)
+contains
+ integer (c_intptr_t) function get_loc (arg)
+ character(kind=4, len=*), target :: arg(:)
+ ! %loc does copy in/out if not simply contiguous
+ ! extra func needed because of 'target' attribute
+ get_loc = transfer (c_loc(arg), res%x)
+ end
+end
+
+type(loc_t) function char_assumed_shape_in_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(kind=4, len=*) :: xx(:)
+ character(kind=4, len=3) :: yy(5:)
+ character(kind=4, len=k) :: zz(-k:)
+ intent(in) :: xx, yy, zz
+ print *, xx(1:3)
+ if (3 /= size(xx)) error stop 80
+ if (3 /= size(yy)) error stop 80
+ if (3 /= size(zz)) error stop 80
+ if (3 /= len(xx)) error stop 81
+ if (3 /= len(yy)) error stop 81
+ if (3 /= len(zz)) error stop 81
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (5 /= lbound(yy, dim=1)) stop 49
+ if (-k /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (7 /= ubound(yy, dim=1)) stop 49
+ if (-k+2 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (is_contiguous (xx)) error stop 89
+ if (is_contiguous (yy)) error stop 89
+ if (is_contiguous (zz)) error stop 89
+ if (xx(1) /= 4_"abc") error stop 82
+ if (xx(2) /= 4_"ghi") error stop 83
+ if (xx(3) /= 4_"nop") error stop 84
+ if (yy(5) /= 4_"abc") error stop 82
+ if (yy(6) /= 4_"ghi") error stop 83
+ if (yy(7) /= 4_"nop") error stop 84
+ if (zz(-k) /= 4_"abc") error stop 82
+ if (zz(-k+1) /= 4_"ghi") error stop 83
+ if (zz(-k+2) /= 4_"nop") error stop 84
+ else if (num == 2) then
+ if (.not.is_contiguous (xx)) error stop 89
+ if (.not.is_contiguous (yy)) error stop 89
+ if (.not.is_contiguous (zz)) error stop 89
+ if (xx(1) /= 4_"def") error stop 85
+ if (xx(2) /= 4_"ghi") error stop 86
+ if (xx(3) /= 4_"jlm") error stop 87
+ if (yy(5) /= 4_"def") error stop 85
+ if (yy(6) /= 4_"ghi") error stop 86
+ if (yy(7) /= 4_"jlm") error stop 87
+ if (zz(-k) /= 4_"def") error stop 85
+ if (zz(-k+1) /= 4_"ghi") error stop 86
+ if (zz(-k+2) /= 4_"jlm") error stop 87
+ else
+ error stop 88
+ endif
+ res%x = get_loc(xx)
+ res%y = get_loc(yy)
+ res%z = get_loc(zz)
+contains
+ integer (c_intptr_t) function get_loc (arg)
+ character(kind=4, len=*), target :: arg(:)
+ ! %loc does copy in/out if not simply contiguous
+ ! extra func needed because of 'target' attribute
+ get_loc = transfer (c_loc(arg), res%x)
+ end
+end
+
+
+
+type(loc_t) function char_assumed_shape_cont_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(kind=4, len=*) :: xx(:)
+ character(kind=4, len=3) :: yy(5:)
+ character(kind=4, len=k) :: zz(-k:)
+ contiguous :: xx, yy, zz
+ print *, xx(1:3)
+ if (3 /= len(xx)) error stop 90
+ if (3 /= len(yy)) error stop 90
+ if (3 /= len(zz)) error stop 90
+ if (3 /= size(xx)) error stop 91
+ if (3 /= size(yy)) error stop 91
+ if (3 /= size(zz)) error stop 91
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (5 /= lbound(yy, dim=1)) stop 49
+ if (-k /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (7 /= ubound(yy, dim=1)) stop 49
+ if (-k+2 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (xx(1) /= 4_"abc") error stop 92
+ if (xx(2) /= 4_"ghi") error stop 93
+ if (xx(3) /= 4_"nop") error stop 94
+ if (yy(5) /= 4_"abc") error stop 92
+ if (yy(6) /= 4_"ghi") error stop 93
+ if (yy(7) /= 4_"nop") error stop 94
+ if (zz(-k) /= 4_"abc") error stop 92
+ if (zz(-k+1) /= 4_"ghi") error stop 93
+ if (zz(-k+2) /= 4_"nop") error stop 94
+ else if (num == 2) then
+ if (xx(1) /= 4_"def") error stop 92
+ if (xx(2) /= 4_"ghi") error stop 93
+ if (xx(3) /= 4_"jlm") error stop 94
+ if (yy(5) /= 4_"def") error stop 92
+ if (yy(6) /= 4_"ghi") error stop 93
+ if (yy(7) /= 4_"jlm") error stop 94
+ if (zz(-k) /= 4_"def") error stop 92
+ if (zz(-k+1) /= 4_"ghi") error stop 93
+ if (zz(-k+2) /= 4_"jlm") error stop 94
+ else
+ error stop 98
+ endif
+ xx(1) = 4_"ABC"
+ xx(2) = 4_"DEF"
+ xx(3) = 4_"GHI"
+ yy(5) = 4_"ABC"
+ yy(6) = 4_"DEF"
+ yy(7) = 4_"GHI"
+ zz(-k) = 4_"ABC"
+ zz(-k+1) = 4_"DEF"
+ zz(-k+2) = 4_"GHI"
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+type(loc_t) function char_assumed_shape_cont_in_f (xx, yy, zz, k, num) bind(c) result(res)
+ integer, value :: num, k
+ character(kind=4, len=*) :: xx(:)
+ character(kind=4, len=3) :: yy(5:)
+ character(kind=4, len=k) :: zz(-k:)
+ intent(in) :: xx, yy, zz
+ contiguous :: xx, yy, zz
+ print *, xx(1:3)
+ if (3 /= size(xx)) error stop 100
+ if (3 /= size(yy)) error stop 100
+ if (3 /= size(zz)) error stop 100
+ if (3 /= len(xx)) error stop 101
+ if (3 /= len(yy)) error stop 101
+ if (3 /= len(zz)) error stop 101
+ if (1 /= lbound(xx, dim=1)) stop 49
+ if (5 /= lbound(yy, dim=1)) stop 49
+ if (-k /= lbound(zz, dim=1)) stop 49
+ if (3 /= ubound(xx, dim=1)) stop 49
+ if (7 /= ubound(yy, dim=1)) stop 49
+ if (-k+2 /= ubound(zz, dim=1)) stop 49
+ if (num == 1) then
+ if (xx(1) /= 4_"abc") error stop 102
+ if (xx(2) /= 4_"ghi") error stop 103
+ if (xx(3) /= 4_"nop") error stop 104
+ if (yy(5) /= 4_"abc") error stop 102
+ if (yy(6) /= 4_"ghi") error stop 103
+ if (yy(7) /= 4_"nop") error stop 104
+ if (zz(-k) /= 4_"abc") error stop 102
+ if (zz(-k+1) /= 4_"ghi") error stop 103
+ if (zz(-k+2) /= 4_"nop") error stop 104
+ else if (num == 2) then
+ if (xx(1) /= 4_"def") error stop 105
+ if (xx(2) /= 4_"ghi") error stop 106
+ if (xx(3) /= 4_"jlm") error stop 107
+ if (yy(5) /= 4_"def") error stop 105
+ if (yy(6) /= 4_"ghi") error stop 106
+ if (yy(7) /= 4_"jlm") error stop 107
+ if (zz(-k) /= 4_"def") error stop 105
+ if (zz(-k+1) /= 4_"ghi") error stop 106
+ if (zz(-k+2) /= 4_"jlm") error stop 107
+ else
+ error stop 108
+ endif
+ res%x = %loc(xx) ! { dg-warning "Legacy Extension" }
+ res%y = %loc(yy) ! { dg-warning "Legacy Extension" }
+ res%z = %loc(zz) ! { dg-warning "Legacy Extension" }
+end
+
+end module
+
+
+use m
+implicit none (type, external)
+character(kind=4, len=3) :: a(6), a2(6), a3(6), a_init(6)
+type(loc_t) :: loc3
+
+a_init = [4_'abc', 4_'def', 4_'ghi', 4_'jlm', 4_'nop', 4_'qrs']
+
+! -- Fortran: assumed size
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- Fortran: explicit shape
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_in_f (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_in_f (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- Fortran: assumed rank
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_f (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_in_f (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- Fortran: assumed rank contiguous
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- Fortran: assumed shape
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_f (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_in_f (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- Fortran: assumed shape contiguous
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_in_f (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_in_f (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+
+! --- character - call C directly --
+
+! -- C: assumed size
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(2:4)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- C: explicit shape
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_in_c (a(::2), a2(::2), a3(::2), size(a(::2)), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_expl_size_in_c (a(2:4), a2(2:4), a3(2:4), size(a(::2)), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- C: assumed rank
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_c (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_in_c (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- C: assumed rank contiguous
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_rank_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- C: assumed shape
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_c (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_in_c (a(::2), a2(::2), a3(::2), len(a), num=1)
+if (loc3%x /= %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+
+! -- C: assumed shape contiguous
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 51 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a2 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+if (any (a3 /= [4_'ABC', 4_'def', 4_'DEF', 4_'jlm', 4_'GHI', 4_'qrs'])) error stop 52
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 53 ! { dg-warning "Legacy Extension" }
+if (any (a /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a2 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+if (any (a3 /= [4_'abc', 4_'ABC', 4_'DEF', 4_'GHI', 4_'nop', 4_'qrs'])) error stop 54
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_in_c (a(::2), a2(::2), a3(::2), len(a), num=1) ! NOTE: run-time copy-in warning
+if (loc3%x == %loc(a)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%y == %loc(a2)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (loc3%z == %loc(a3)) error stop 55 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 56
+if (any (a2 /= a_init)) error stop 56
+if (any (a3 /= a_init)) error stop 56
+
+a = a_init; a2 = a_init; a3 = a_init
+loc3 = char_assumed_shape_cont_in_c (a(2:4), a2(2:4), a3(2:4), len(a), num=2)
+if (loc3%x /= %loc(a(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%y /= %loc(a2(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (loc3%z /= %loc(a3(2))) error stop 57 ! { dg-warning "Legacy Extension" }
+if (any (a /= a_init)) error stop 58
+if (any (a2 /= a_init)) error stop 58
+if (any (a3 /= a_init)) error stop 58
+end
+
+
+! { dg-output "At line 928 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 928 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 928 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 946 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 946 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 946 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 965 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 965 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 965 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 983 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 983 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 983 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1039 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1039 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1039 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1057 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1057 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1057 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1113 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1113 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1113 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1131 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1131 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output "At line 1131 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_f'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1153 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1153 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1153 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1171 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1171 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1171 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1190 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1190 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1190 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1208 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1208 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1208 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_expl_size_in_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1264 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1264 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1264 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1282 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1282 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1282 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_rank_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1338 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1338 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1338 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
+! { dg-output "At line 1356 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'xx' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1356 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'yy' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output "At line 1356 of file .*bind-c-contiguous-5.f90(\n|\r\n|\r)" }"
+! { dg-output "Fortran runtime warning: An array temporary was created for argument 'zz' of procedure 'char_assumed_shape_cont_in_c'(\n|\r\n|\r)" }"
+! { dg-output " abcghinop(\n|\r\n|\r)" }"
+! { dg-output " defghijlm(\n|\r\n|\r)" }"
diff --git a/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90 b/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90
index 39822c0753a..d416fa5ea94 100644
--- a/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90
+++ b/gcc/testsuite/gfortran.dg/bind-c-intent-out.f90
@@ -1,4 +1,4 @@
-! { dg-do compile }
+! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! PR fortran/91863
@@ -28,15 +28,20 @@ program p
if (.not.allocated(a)) stop 1
if (any(shape(a) /= [3])) stop 2
if (lbound(a,1) /= 3 .or. ubound(a,1) /= 5) stop 3
+ print *, a(0), a(1), a(2), a(3), a(4)
+ print *, a
if (any(a /= [1, 2, 3])) stop 4
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" } }
diff --git a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90
index ede6eff67fa..8dd7e8fb088 100644
--- a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90
+++ b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90
@@ -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" } }
+
+
diff --git a/gcc/testsuite/gfortran.dg/bind_c_char_10.f90 b/gcc/testsuite/gfortran.dg/bind_c_char_10.f90
index 35958515d38..7c6f4dcc961 100644
--- a/gcc/testsuite/gfortran.dg/bind_c_char_10.f90
+++ b/gcc/testsuite/gfortran.dg/bind_c_char_10.f90
@@ -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" } }
+
diff --git a/gcc/testsuite/gfortran.dg/bind_c_char_8.f90 b/gcc/testsuite/gfortran.dg/bind_c_char_8.f90
index c6f406f3c5c..8e6413d0bf4 100644
--- a/gcc/testsuite/gfortran.dg/bind_c_char_8.f90
+++ b/gcc/testsuite/gfortran.dg/bind_c_char_8.f90
@@ -28,7 +28,7 @@ subroutine s3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1.
character(len=n) :: xn
end
-subroutine s4 (xstar) bind(C) ! { dg-error "Sorry, character dummy argument 'xstar' at .1. with assumed length is not yet supported for procedure 's4' with BIND\\(C\\) attribute" }
+subroutine s4 (xstar) bind(C)
character(len=*) :: xstar
end
@@ -85,7 +85,7 @@ subroutine az3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1
character(len=n) :: xn(*)
end
-subroutine az4 (xstar) bind(C) ! { dg-error "Sorry, character dummy argument 'xstar' at .1. with assumed length is not yet supported for procedure 'az4' with BIND\\(C\\) attribute" }
+subroutine az4 (xstar) bind(C)
character(len=*) :: xstar(*)
end
@@ -104,7 +104,7 @@ subroutine ae3 (xn, n) bind(C) ! { dg-error "Character dummy argument 'xn' at .1
character(len=n) :: xn(9)
end
-subroutine ae4 (xstar) bind(C) ! { dg-error "Sorry, character dummy argument 'xstar' at .1. with assumed length is not yet supported for procedure 'ae4' with BIND\\(C\\) attribute" }
+subroutine ae4 (xstar) bind(C)
character(len=*) :: xstar(3)
end
@@ -128,7 +128,7 @@ subroutine s4a (xstar) bind(C) ! { dg-error "Allocatable character dummy argumen
character(len=*), allocatable :: xstar
end
-subroutine s5a (xcolon) bind(C) ! { dg-error "Sorry, deferred-length scalar character dummy argument 'xcolon' at .1. of procedure 's5a' with BIND\\(C\\) not yet supported" }
+subroutine s5a (xcolon) bind(C)
character(len=:), allocatable :: xcolon
end
@@ -198,7 +198,7 @@ subroutine s4p (xstar) bind(C) ! { dg-error "Pointer character dummy argument 'x
character(len=*), pointer :: xstar
end
-subroutine s5p (xcolon) bind(C) ! { dg-error "Sorry, deferred-length scalar character dummy argument 'xcolon' at .1. of procedure 's5p' with BIND\\(C\\) not yet supported" }
+subroutine s5p (xcolon) bind(C)
character(len=:), pointer :: xcolon
end
diff --git a/gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy.f90 b/gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy.f90
index 4161a30b16a..1d0cf65ba0c 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy.f90
@@ -1,6 +1,6 @@
! PR 101308
! PR 92621(?)
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "allocatable-dummy-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90
index 62fee2c4f50..fb91107bd9b 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90
@@ -56,7 +56,7 @@ module m
end subroutine
! dummy is assumed length character variable
- subroutine s6 (x) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ subroutine s6 (x) bind (c)
use ISO_C_BINDING
implicit none
character(len=*) :: x
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90
index c77e6ac3334..699f75f6142 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90
@@ -44,7 +44,7 @@ subroutine s2 (x)
implicit none
type(*) :: x(*)
- call g (x, 1) ! { dg-error "Assumed.type" }
+ call g (x, 1) ! { dg-error "Assumed-type actual argument at .1. corresponding to assumed-rank dummy argument 'a' must be assumed-shape or assumed-rank" }
end subroutine
! Check that a scalar gives an error.
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5.f90
index f178bb8d733..b5edf528417 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5.f90
@@ -7,7 +7,7 @@
! in C works and that you can use it to call back into a Fortran function
! with an assumed-length dummy that is declared with C binding.
-subroutine ftest (a, n) bind (c, name="ftest") ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+subroutine ftest (a, n) bind (c, name="ftest")
use iso_c_binding
character(kind=C_CHAR, len=*) :: a
integer(C_INT), value :: n
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3.f90
index 5e5f5955973..d85a78a8a6c 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3.f90
@@ -1,5 +1,5 @@
! PR 92621 (?)
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "cf-out-descriptor-3-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4.f90
index 082610c2da7..e14c7571ea2 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4.f90
@@ -1,5 +1,5 @@
! PR 92621 (?)
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "cf-out-descriptor-4-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5.f90
index ff1e31d345f..b0dd20ce5f8 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5.f90
@@ -6,7 +6,7 @@
! This program checks use of an assumed-length character dummy argument
! as an intent(out) parameter in subroutines with C binding.
-subroutine ftest (a, n) bind (c, name="ftest") ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+subroutine ftest (a, n) bind (c, name="ftest")
use iso_c_binding
character(kind=C_CHAR, len=*), intent(out) :: a
integer(C_INT), value :: n
@@ -20,13 +20,13 @@ program testit
implicit none
interface
- subroutine ctest (a, n) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ subroutine ctest (a, n) bind (c)
use iso_c_binding
character(kind=C_CHAR, len=*), intent(out) :: a
integer(C_INT), value :: n
end subroutine
- subroutine ftest (a, n) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ subroutine ftest (a, n) bind (c)
use iso_c_binding
character(kind=C_CHAR, len=*), intent(out) :: a
integer(C_INT), value :: n
diff --git a/gcc/testsuite/gfortran.dg/c-interop/contiguous-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/contiguous-2.f90
index bb8ba20a5b2..195ec8c183c 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/contiguous-2.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/contiguous-2.f90
@@ -1,5 +1,5 @@
! PR 101304
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "contiguous-2-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
diff --git a/gcc/testsuite/gfortran.dg/c-interop/contiguous-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/contiguous-3.f90
index 9a6d66b14fd..0a295721c5b 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/contiguous-3.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/contiguous-3.f90
@@ -1,5 +1,5 @@
! PR 101304
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "contiguous-3-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
diff --git a/gcc/testsuite/gfortran.dg/c-interop/deferred-character-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/deferred-character-1.f90
index bd6d9cb3dd9..3c3c2574101 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/deferred-character-1.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/deferred-character-1.f90
@@ -16,12 +16,12 @@ module m
interface
! These are supposed to be OK
- subroutine good1 (x, n) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ subroutine good1 (x, n) bind (c)
use iso_c_binding
character (kind=C_CHAR, len=:), allocatable :: x
integer(C_INT), value :: n
end subroutine
- subroutine good2 (x, n) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ subroutine good2 (x, n) bind (c)
use iso_c_binding
character (kind=C_CHAR, len=:), pointer :: x
integer(C_INT), value :: n
diff --git a/gcc/testsuite/gfortran.dg/c-interop/deferred-character-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/deferred-character-2.f90
index 9fd046def4c..356097af241 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/deferred-character-2.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/deferred-character-2.f90
@@ -43,7 +43,7 @@ program testit
p = 'bar'
end subroutine
- subroutine frobc (a, p) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ subroutine frobc (a, p) bind (c)
use iso_c_binding
character (kind=C_CHAR, len=:), allocatable :: a
character (kind=C_CHAR, len=:), pointer :: p
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3.f90
index 174d1e728fd..c65cb7a3944 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3.f90
@@ -1,5 +1,5 @@
! PR 101308
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "fc-descriptor-3-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5.f90
index 5ac406fdcc1..eda65b431db 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5.f90
@@ -11,7 +11,7 @@ program testit
implicit none
interface
- subroutine ctest (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ subroutine ctest (a) bind (c)
use iso_c_binding
character(len=*,kind=C_CHAR) :: a
end subroutine
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6.f90
index 8c544d18402..1d6d006853d 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6.f90
@@ -1,5 +1,5 @@
! Reported as pr94070.
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "fc-descriptor-6-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7-c.c
index 81d826f276f..035de03636a 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7-c.c
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7-c.c
@@ -3,14 +3,18 @@
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
-extern void ctest (CFI_cdesc_t *a);
+extern void ctest (CFI_cdesc_t *, _Bool);
void
-ctest (CFI_cdesc_t *a)
+ctest (CFI_cdesc_t *a, _Bool is_cont)
{
+ CFI_index_t subscripts[2];
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
+
+#if DEBUG
dump_CFI_cdesc_t (a);
+#endif
/* We expect to get an array of shape (5,10) that may not be
contiguous. */
@@ -33,14 +37,17 @@ ctest (CFI_cdesc_t *a)
if (a->dim[1].extent != 10)
abort ();
- /* There shall be an ordering of the dimensions such that the absolute
- value of the sm member of the first dimension is not less than the
- elem_len member of the C descriptor and the absolute value of the sm
- member of each subsequent dimension is not less than the absolute
- value of the sm member of the previous dimension multiplied
- by the extent of the previous dimension. */
- if (abs (a->dim[0].sm) < a->elem_len)
+ if (is_cont != CFI_is_contiguous (a))
abort ();
- if (abs (a->dim[1].sm) < abs (a->dim[0].sm) * a->dim[0].extent)
+
+ if (abs (a->dim[0].sm) < a->elem_len)
abort ();
+
+ for (int j = 0; j < 5; ++j)
+ for (int i = 0; i < 10; ++i)
+ {
+ subscripts[0] = j; subscripts[1] = i;
+ if (*(int *) CFI_address (a, subscripts) != (i+1) + 100*(j+1))
+ abort ();
+ }
}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7.f90
index 5be72e7e01c..40f2e33a4c9 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7.f90
@@ -1,5 +1,5 @@
! PR 101309
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "fc-descriptor-7-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
@@ -8,30 +8,140 @@
program testit
use iso_c_binding
- implicit none
+ implicit none (type, external)
interface
- subroutine ctest (a) bind (c)
+ subroutine ctest (a, is_cont) bind (c)
use iso_c_binding
- integer(C_INT), intent (in) :: a(:,:)
+ integer(C_INT) :: a(:,:)
+ logical(C_Bool), value :: is_cont
+ end subroutine
+ subroutine ctest_cont (a, is_cont) bind (c, name="ctest")
+ use iso_c_binding
+ integer(C_INT), contiguous :: a(:,:)
+ logical(C_Bool), value :: is_cont
+ end subroutine
+
+ subroutine ctest_ar (a, is_cont) bind (c, name="ctest")
+ use iso_c_binding
+ integer(C_INT) :: a(..)
+ logical(C_Bool), value :: is_cont
+ end subroutine
+ subroutine ctest_ar_cont (a, is_cont) bind (c, name="ctest")
+ use iso_c_binding
+ integer(C_INT), contiguous :: a(..)
+ logical(C_Bool), value :: is_cont
end subroutine
end interface
+ integer :: i , j
integer(C_INT), target :: aa(10,5)
integer(C_INT), target :: bb(10,10)
+ ! Original array
+ do j = 1, 5
+ do i = 1, 10
+ aa(i,j) = i + 100*j
+ end do
+ end do
+
+ ! Transposed array
+ do j = 2, 10, 2
+ do i = 1, 10
+ bb(j, i) = i + 100*((j-2)/2 + 1)
+ end do
+ end do
+
+ if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
+
! Test both calling the C function directly, and via another function
- ! that takes an assumed-shape argument.
- call ctest (transpose (aa))
- call ftest (transpose (aa))
- call ctest (bb(2:10:2, :))
- call ftest (bb(2:10:2, :))
+ ! that takes an assumed-shape/assumed-rank argument.
+
+ call ftest (transpose (aa), is_cont=.true._c_bool) ! Implementation choice: copy in; hence, contiguous
+ if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
+
+ call ctest (transpose (aa), is_cont=.false._c_bool) ! Implementation choice: noncontigous / sm inversed
+ if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
+ call ctest_cont (transpose (aa), is_cont=.true._c_bool)
+ if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
+ call ctest_ar (transpose (aa), is_cont=.false._c_bool) ! Implementation choice: noncontigous / sm inversed
+ if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
+ call ctest_ar_cont (transpose (aa), is_cont=.true._c_bool)
+ if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
+
+
+ call ftest (bb(2:10:2, :), is_cont=.false._c_bool)
+ if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
+
+ call ctest (bb(2:10:2, :), is_cont=.false._c_bool)
+ if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
+ call ctest_cont (bb(2:10:2, :), is_cont=.true._c_bool)
+ if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
+ call ctest_ar (bb(2:10:2, :), is_cont=.false._c_bool)
+ if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
+ call ctest_ar_cont (bb(2:10:2, :), is_cont=.true._c_bool)
+ if (any (transpose (aa) /= bb(2:10:2, :))) error stop 1
contains
- subroutine ftest (a)
+ subroutine ftest (a, is_cont)
use iso_c_binding
- integer(C_INT), intent(in) :: a(:,:)
- call ctest (a)
+ integer(C_INT) :: a(:,:)
+ logical(c_bool), value, intent(in) :: is_cont
+ if (is_cont .NEQV. is_contiguous (a)) error stop 2
+ if (any (shape (a) /= [5, 10])) error stop 3
+ do j = 1, 5
+ do i = 1, 10
+ if (a(j, i) /= i + 100*j) error stop 4
+ if (a(j, i) /= aa(i,j)) error stop
+ end do
+ end do
+ call ctest (a, is_cont)
+ call ctest_cont (a, is_cont=.true._c_bool)
+ call ctest_ar (a, is_cont)
+ call ctest_ar_cont (a, is_cont=.true._c_bool)
end subroutine
+ subroutine ftest_ar (a, is_cont)
+ use iso_c_binding
+ integer(C_INT) :: a(..)
+ logical(c_bool), value, intent(in) :: is_cont
+ if (is_cont .NEQV. is_contiguous (a)) error stop 2
+ if (any (shape (a) /= [5, 10])) error stop 3
+ select rank (a)
+ rank(2)
+ do j = 1, 5
+ do i = 1, 10
+ if (a(j, i) /= i + 100*j) error stop 4
+ if (a(j, i) /= aa(i,j)) error stop
+ end do
+ end do
+ call ctest (a, is_cont)
+ call ctest_cont (a, is_cont=.true._c_bool)
+ call ftest_ar_con (a, is_cont=.true._c_bool)
+ end select
+ call ctest_ar (a, is_cont)
+ ! call ctest_ar_cont (a, is_cont=.true._c_bool) ! TODO/FIXME: ICE, cf. PR fortran/102729
+ ! call ftest_ar_con (a, is_cont=.true._c_bool) ! TODO/FIXME: ICE, cf. PR fortran/102729
+ end subroutine
+
+ subroutine ftest_ar_con (a, is_cont)
+ use iso_c_binding
+ integer(C_INT), contiguous :: a(..)
+ logical(c_bool), value, intent(in) :: is_cont
+ if (is_cont .NEQV. is_contiguous (a)) error stop 2
+ if (any (shape (a) /= [5, 10])) error stop 3
+ select rank (a)
+ rank(2)
+ do j = 1, 5
+ do i = 1, 10
+ if (a(j, i) /= i + 100*j) error stop 4
+ if (a(j, i) /= aa(i,j)) error stop
+ end do
+ end do
+ call ctest (a, is_cont)
+ call ctest_cont (a, is_cont=.true._c_bool)
+ end select
+ call ctest_ar (a, is_cont)
+ call ctest_ar_cont (a, is_cont=.true._c_bool)
+ end subroutine
end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-3.f90
index c555ada7996..00a083e269e 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-3.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-3.f90
@@ -1,5 +1,5 @@
! PR 101308
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "fc-out-descriptor-3-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-4.f90
index b4f6654c2e1..a26d4955200 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-4.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-4.f90
@@ -1,5 +1,5 @@
! PR 92621 (?)
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "fc-out-descriptor-4-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-5.f90
index 836683bd971..63fc08f8bb0 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-5.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-5.f90
@@ -10,7 +10,7 @@ program testit
implicit none
interface
- subroutine ctest (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ subroutine ctest (a) bind (c)
use iso_c_binding
character(len=*,kind=C_CHAR), intent(out) :: a
end subroutine
@@ -26,7 +26,7 @@ program testit
call ftest (aa)
contains
- subroutine ftest (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ subroutine ftest (a) bind (c)
use iso_c_binding
character(len=*,kind=C_CHAR), intent(out) :: a
call ctest (a)
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-6.f90
index d0c3904e27e..da226158a35 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-6.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-6.f90
@@ -1,5 +1,5 @@
! Reported as pr94070.
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "fc-out-descriptor-6-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
diff --git a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-5.f90
index 2420b7d3731..e6d17a401cd 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-5.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-5.f90
@@ -17,7 +17,7 @@ contains
! C binding version
- subroutine checkc (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ subroutine checkc (a) bind (c)
use iso_c_binding
character(len=*,kind=C_CHAR) :: a
@@ -37,7 +37,7 @@ contains
end subroutine
! C binding version
- subroutine testc (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ subroutine testc (a) bind (c)
use iso_c_binding
character(len=*,kind=C_CHAR) :: a
diff --git a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-6.f90
index 8b1167e65fe..090bb153fdb 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-6.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-6.f90
@@ -1,5 +1,5 @@
! Reported as pr94070.
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
!
! This program checks that passing assumed-size arrays to
! and from Fortran functions with C binding works.
diff --git a/gcc/testsuite/gfortran.dg/c-interop/shape.f90 b/gcc/testsuite/gfortran.dg/c-interop/shape.f90
index dd790bbca90..d05de25d146 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/shape.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/shape.f90
@@ -15,7 +15,7 @@
! subroutine with an assumed-rank dummy.
program test
-
+ implicit none
! Define some arrays for testing.
integer, target :: x1(5)
integer :: y1(0:9)
@@ -51,7 +51,7 @@ contains
r = rank(a)
block
- integer :: s(r)
+ integer :: s(r), i
s = shape(a)
do i = 1, r
if (s(i) .ne. size(a,i)) stop 101
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char-c.c b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char-c.c
index c69d2242865..ca2f49dc531 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char-c.c
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char-c.c
@@ -33,3 +33,9 @@ ctest_1 (CFI_cdesc_t *arg_char, CFI_cdesc_t *arg_ucs4)
check (arg_ucs4, 4, CFI_type_ucs4_char);
}
+void
+ctest_5 (CFI_cdesc_t *arg_char, CFI_cdesc_t *arg_ucs4)
+{
+ check (arg_char, 5*1, CFI_type_char);
+ check (arg_ucs4, 5*4, CFI_type_ucs4_char);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char.f90
index ede9fb6039a..71f84d0f37a 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char.f90
@@ -27,11 +27,21 @@ program testit
character(kind=ucs4) :: arg_ucs4(:)
end subroutine
+ subroutine ctest_5 (arg_cchar, arg_ucs4) bind (c)
+ use iso_c_binding
+ integer, parameter :: ucs4 = selected_char_kind ('ISO_10646')
+ character(kind=C_CHAR,len=*) :: arg_cchar(:)
+ character(kind=ucs4,len=*) :: arg_ucs4(:)
+ end subroutine
+
end interface
character(kind=C_CHAR) :: var_cchar(4)
character(kind=ucs4) :: var_ucs4(4)
+ character(kind=C_CHAR,len=5) :: var_cchar_5(4)
+ character(kind=ucs4,len=5) :: var_ucs4_5(4)
call ctest_1 (var_cchar, var_ucs4)
+ call ctest_5 (var_cchar_5, var_ucs4_5)
end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128.f90
index 907877b923e..66737b2b7ce 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128.f90
@@ -2,7 +2,7 @@
! PR 100914
! PR 100917
! Fails on x86 targets where sizeof(long double) == 16 (PR100917).
-! { dg-do run { xfail { { x86_64*-*-* i?86*-*-* } && longdouble128 } } }
+! { dg-do run }
! { dg-require-effective-target fortran_real_c_float128 }
! { dg-additional-sources "typecodes-array-float128-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic.f90
index 5f7446826a8..b586b1fd7ad 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic.f90
@@ -1,7 +1,7 @@
! PR 101305
! PR 100917
! xfailed due to PR 101308
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "typecodes-scalar-basic-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128.f90
index edf91450ff8..c2275c4face 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128.f90
@@ -1,7 +1,7 @@
! xfailed due to PR 101308
! PR 101305
! PR 100914
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-require-effective-target fortran_real_c_float128 }
! { dg-additional-sources "typecodes-scalar-float128-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128.f90
index 5f3c7e1ccf7..157c4ca1f65 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128.f90
@@ -1,6 +1,6 @@
! PR 101305
! xfailed due to PR 101308
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-require-effective-target fortran_integer_16 }
! { dg-additional-sources "typecodes-scalar-int128-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble.f90
index c32e01218b6..ddc54f4d672 100644
--- a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble.f90
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble.f90
@@ -1,7 +1,7 @@
! xfailed due to PR 101308
! PR 101305
! PR 100917
-! { dg-do run { xfail *-*-* } }
+! { dg-do run }
! { dg-additional-sources "typecodes-scalar-longdouble-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
diff --git a/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90 b/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90
index a2616568b2a..2a4a618fa50 100644
--- a/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90
+++ b/gcc/testsuite/gfortran.dg/iso_c_binding_char_1.f90
@@ -4,8 +4,7 @@
!
! Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
!
-subroutine bar(c,d) BIND(C) ! { dg-error "character dummy argument 'c' at .1. with assumed length is not yet supported for procedure 'bar' with BIND\\(C\\) attribute" }
- ! { dg-error "Character dummy argument 'd' at .1. must be of constant length of one or assumed length, unless it has assumed shape or assumed rank, as procedure 'bar' has the BIND\\(C\\) attribute" "" { target *-*-* } .-1 }
+subroutine bar(c,d) BIND(C) ! { dg-error "Character dummy argument 'd' at .1. must be of constant length of one or assumed length, unless it has assumed shape or assumed rank, as procedure 'bar' has the BIND\\(C\\) attribute" }
character (len=*) c
character (len=2) d
end
diff --git a/gcc/testsuite/gfortran.dg/pr93792.f90 b/gcc/testsuite/gfortran.dg/pr93792.f90
index 960d05025ab..c7939af9df3 100644
--- a/gcc/testsuite/gfortran.dg/pr93792.f90
+++ b/gcc/testsuite/gfortran.dg/pr93792.f90
@@ -14,4 +14,4 @@ end
! { dg-error "Parameterized type 't' does not have a component" " " { target *-*-* } 5 }
! { dg-error "BOZ literal constant at .1. cannot appear" " " { target *-*-* } 6 }
! { dg-error "Cannot open module file" " " { target *-*-* } 10 }
-! { dg-excess-errors "compilation terminated" }
+! { dg-prune-output "compilation terminated" }
diff --git a/libgfortran/ISO_Fortran_binding.h b/libgfortran/ISO_Fortran_binding.h
index d431d09e61b..6abac8f9e3a 100644
--- a/libgfortran/ISO_Fortran_binding.h
+++ b/libgfortran/ISO_Fortran_binding.h
@@ -152,14 +152,10 @@ extern int CFI_setpointer (CFI_cdesc_t *, CFI_cdesc_t *, const CFI_index_t []);
#define CFI_type_Complex 4
#define CFI_type_Character 5
-/* Types with no kind. FIXME: GFC descriptors currently use BT_VOID for
- both C_PTR and C_FUNPTR, so we have no choice but to make them
- identical here too. That can potentially break on targets where
- function and data pointers have different sizes/representations.
- See PR 100915. */
+/* Types with no kind. */
#define CFI_type_struct 6
#define CFI_type_cptr 7
-#define CFI_type_cfunptr CFI_type_cptr
+#define CFI_type_cfunptr 8
#define CFI_type_other -1
/* Types with kind parameter.
diff --git a/libgfortran/runtime/ISO_Fortran_binding.c b/libgfortran/runtime/ISO_Fortran_binding.c
index e01cc650e90..a247725a237 100644
--- a/libgfortran/runtime/ISO_Fortran_binding.c
+++ b/libgfortran/runtime/ISO_Fortran_binding.c
@@ -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)
{
@@ -122,6 +124,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)
{
diff --git a/libgomp/testsuite/libgomp.fortran/optional-bind-c.f90 b/libgomp/testsuite/libgomp.fortran/optional-bind-c.f90
new file mode 100644
index 00000000000..6ad6eadbcd2
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/optional-bind-c.f90
@@ -0,0 +1,18 @@
+! With bind(C), the C (CFI) array descriptor is converted to
+! a Fortran array descriptor - thus, internally a PARM_DECL is
+! converted to a VAR_DECL - check that the optional check still works
+
+module m
+contains
+subroutine foo(x, y) bind(C)
+ integer, optional :: x,y(:)
+ !$omp target map(tofrom:x)
+ if (present (x)) x = 5
+ if (present (y)) y(1) = 5
+ !$omp end target
+end
+end
+
+use m
+call foo()
+end
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-10-18 8:29 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-10-18 8:29 [gcc r12-4467] Fortran: Fix Bind(C) Array-Descriptor Conversion Tobias Burnus
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).