public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc/devel/omp/gcc-11] Fortran: TS 29113 testsuite
@ 2021-09-18 5:31 Sandra Loosemore
0 siblings, 0 replies; only message in thread
From: Sandra Loosemore @ 2021-09-18 5:31 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:49b151fd66c513206e74e7b7729fc465f9fee8c0
commit 49b151fd66c513206e74e7b7729fc465f9fee8c0
Author: Sandra Loosemore <sandra@codesourcery.com>
Date: Fri Sep 17 10:08:45 2021 -0700
Fortran: TS 29113 testsuite
Add tests to exercise features added to Fortran via TS 29113, "Further
Interoperability of Fortran with C":
https://wg5-fortran.org/N1901-N1950/N1942.pdf
2021-09-01 Sandra Loosemore <sandra@codesourcery.com>
gcc/testsuite/
* gfortran.dg/c-interop/allocatable-dummy-c.c: New file.
* gfortran.dg/c-interop/allocatable-dummy.f90: New file.
* gfortran.dg/c-interop/allocatable-optional-pointer.f90: New file.
* gfortran.dg/c-interop/allocate-c.c: New file.
* gfortran.dg/c-interop/allocate-errors-c.c: New file.
* gfortran.dg/c-interop/allocate-errors.f90: New file.
* gfortran.dg/c-interop/allocate.f90: New file.
* gfortran.dg/c-interop/argument-association-assumed-rank-1.f90:
New file.
* gfortran.dg/c-interop/argument-association-assumed-rank-2.f90:
New file.
* gfortran.dg/c-interop/argument-association-assumed-rank-3.f90:
New file.
* gfortran.dg/c-interop/argument-association-assumed-rank-4.f90:
New file.
* gfortran.dg/c-interop/argument-association-assumed-rank-5.f90:
New file.
* gfortran.dg/c-interop/argument-association-assumed-rank-6.f90:
New file.
* gfortran.dg/c-interop/argument-association-assumed-rank-7.f90:
New file.
* gfortran.dg/c-interop/argument-association-assumed-rank-8.f90:
New file.
* gfortran.dg/c-interop/assumed-type-dummy.f90: New file.
* gfortran.dg/c-interop/c-interop.exp: New file.
* gfortran.dg/c-interop/c1255-1.f90: New file.
* gfortran.dg/c-interop/c1255-2.f90: New file.
* gfortran.dg/c-interop/c1255a.f90: New file.
* gfortran.dg/c-interop/c407a-1.f90: New file.
* gfortran.dg/c-interop/c407a-2.f90: New file.
* gfortran.dg/c-interop/c407b-1.f90: New file.
* gfortran.dg/c-interop/c407b-2.f90: New file.
* gfortran.dg/c-interop/c407c-1.f90: New file.
* gfortran.dg/c-interop/c516.f90: New file.
* gfortran.dg/c-interop/c524a.f90: New file.
* gfortran.dg/c-interop/c535a-1.f90: New file.
* gfortran.dg/c-interop/c535a-2.f90: New file.
* gfortran.dg/c-interop/c535b-1.f90: New file.
* gfortran.dg/c-interop/c535b-2.f90: New file.
* gfortran.dg/c-interop/c535b-3.f90: New file.
* gfortran.dg/c-interop/c535c-1.f90: New file.
* gfortran.dg/c-interop/c535c-2.f90: New file.
* gfortran.dg/c-interop/c535c-3.f90: New file.
* gfortran.dg/c-interop/c535c-4.f90: New file.
* gfortran.dg/c-interop/cf-descriptor-1-c.c: New file.
* gfortran.dg/c-interop/cf-descriptor-1.f90: New file.
* gfortran.dg/c-interop/cf-descriptor-2-c.c: New file.
* gfortran.dg/c-interop/cf-descriptor-2.f90: New file.
* gfortran.dg/c-interop/cf-descriptor-3-c.c: New file.
* gfortran.dg/c-interop/cf-descriptor-3.f90: New file.
* gfortran.dg/c-interop/cf-descriptor-4-c.c: New file.
* gfortran.dg/c-interop/cf-descriptor-4.f90: New file.
* gfortran.dg/c-interop/cf-descriptor-5-c.c: New file.
* gfortran.dg/c-interop/cf-descriptor-5.f90: New file.
* gfortran.dg/c-interop/cf-descriptor-6-c.c: New file.
* gfortran.dg/c-interop/cf-descriptor-6.f90: New file.
* gfortran.dg/c-interop/cf-descriptor-7-c.c: New file.
* gfortran.dg/c-interop/cf-descriptor-7.f90: New file.
* gfortran.dg/c-interop/cf-descriptor-8-c.c: New file.
* gfortran.dg/c-interop/cf-descriptor-8.f90: New file.
* gfortran.dg/c-interop/cf-out-descriptor-1-c.c: New file.
* gfortran.dg/c-interop/cf-out-descriptor-1.f90: New file.
* gfortran.dg/c-interop/cf-out-descriptor-2-c.c: New file.
* gfortran.dg/c-interop/cf-out-descriptor-2.f90: New file.
* gfortran.dg/c-interop/cf-out-descriptor-3-c.c: New file.
* gfortran.dg/c-interop/cf-out-descriptor-3.f90: New file.
* gfortran.dg/c-interop/cf-out-descriptor-4-c.c: New file.
* gfortran.dg/c-interop/cf-out-descriptor-4.f90: New file.
* gfortran.dg/c-interop/cf-out-descriptor-5-c.c: New file.
* gfortran.dg/c-interop/cf-out-descriptor-5.f90: New file.
* gfortran.dg/c-interop/cf-out-descriptor-6-c.c: New file.
* gfortran.dg/c-interop/cf-out-descriptor-6.f90: New file.
* gfortran.dg/c-interop/contiguous-1-c.c: New file.
* gfortran.dg/c-interop/contiguous-1.f90: New file.
* gfortran.dg/c-interop/contiguous-2-c.c: New file.
* gfortran.dg/c-interop/contiguous-2.f90: New file.
* gfortran.dg/c-interop/contiguous-3-c.c: New file.
* gfortran.dg/c-interop/contiguous-3.f90: New file.
* gfortran.dg/c-interop/deferred-character-1.f90: New file.
* gfortran.dg/c-interop/deferred-character-2.f90: New file.
* gfortran.dg/c-interop/dump-descriptors.c: New file.
* gfortran.dg/c-interop/dump-descriptors.h: New file.
* gfortran.dg/c-interop/establish-c.c: New file.
* gfortran.dg/c-interop/establish-errors-c.c: New file.
* gfortran.dg/c-interop/establish-errors.f90: New file.
* gfortran.dg/c-interop/establish.f90: New file.
* gfortran.dg/c-interop/explicit-interface.f90: New file.
* gfortran.dg/c-interop/fc-descriptor-1-c.c: New file.
* gfortran.dg/c-interop/fc-descriptor-1.f90: New file.
* gfortran.dg/c-interop/fc-descriptor-2-c.c: New file.
* gfortran.dg/c-interop/fc-descriptor-2.f90: New file.
* gfortran.dg/c-interop/fc-descriptor-3-c.c: New file.
* gfortran.dg/c-interop/fc-descriptor-3.f90: New file.
* gfortran.dg/c-interop/fc-descriptor-4-c.c: New file.
* gfortran.dg/c-interop/fc-descriptor-4.f90: New file.
* gfortran.dg/c-interop/fc-descriptor-5-c.c: New file.
* gfortran.dg/c-interop/fc-descriptor-5.f90: New file.
* gfortran.dg/c-interop/fc-descriptor-6-c.c: New file.
* gfortran.dg/c-interop/fc-descriptor-6.f90: New file.
* gfortran.dg/c-interop/fc-descriptor-7-c.c: New file.
* gfortran.dg/c-interop/fc-descriptor-7.f90: New file.
* gfortran.dg/c-interop/fc-descriptor-8-c.c: New file.
* gfortran.dg/c-interop/fc-descriptor-8.f90: New file.
* gfortran.dg/c-interop/fc-descriptor-9-c.c: New file.
* gfortran.dg/c-interop/fc-descriptor-9.f90: New file.
* gfortran.dg/c-interop/fc-out-descriptor-1-c.c: New file.
* gfortran.dg/c-interop/fc-out-descriptor-1.f90: New file.
* gfortran.dg/c-interop/fc-out-descriptor-2-c.c: New file.
* gfortran.dg/c-interop/fc-out-descriptor-2.f90: New file.
* gfortran.dg/c-interop/fc-out-descriptor-3-c.c: New file.
* gfortran.dg/c-interop/fc-out-descriptor-3.f90: New file.
* gfortran.dg/c-interop/fc-out-descriptor-4-c.c: New file.
* gfortran.dg/c-interop/fc-out-descriptor-4.f90: New file.
* gfortran.dg/c-interop/fc-out-descriptor-5-c.c: New file.
* gfortran.dg/c-interop/fc-out-descriptor-5.f90: New file.
* gfortran.dg/c-interop/fc-out-descriptor-6-c.c: New file.
* gfortran.dg/c-interop/fc-out-descriptor-6.f90: New file.
* gfortran.dg/c-interop/fc-out-descriptor-7-c.c: New file.
* gfortran.dg/c-interop/fc-out-descriptor-7.f90: New file.
* gfortran.dg/c-interop/ff-descriptor-1.f90: New file.
* gfortran.dg/c-interop/ff-descriptor-2.f90: New file.
* gfortran.dg/c-interop/ff-descriptor-3.f90: New file.
* gfortran.dg/c-interop/ff-descriptor-4.f90: New file.
* gfortran.dg/c-interop/ff-descriptor-5.f90: New file.
* gfortran.dg/c-interop/ff-descriptor-6.f90: New file.
* gfortran.dg/c-interop/ff-descriptor-7.f90: New file.
* gfortran.dg/c-interop/note-5-3.f90: New file.
* gfortran.dg/c-interop/note-5-4-c.c: New file.
* gfortran.dg/c-interop/note-5-4.f90: New file.
* gfortran.dg/c-interop/optional-c.c: New file.
* gfortran.dg/c-interop/optional.f90: New file.
* gfortran.dg/c-interop/rank-class.f90: New file.
* gfortran.dg/c-interop/rank.f90: New file.
* gfortran.dg/c-interop/removed-restrictions-1.f90: New file.
* gfortran.dg/c-interop/removed-restrictions-2.f90: New file.
* gfortran.dg/c-interop/removed-restrictions-3.f90: New file.
* gfortran.dg/c-interop/removed-restrictions-4.f90: New file.
* gfortran.dg/c-interop/section-1-c.c: New file.
* gfortran.dg/c-interop/section-1.f90: New file.
* gfortran.dg/c-interop/section-1p.f90: New file.
* gfortran.dg/c-interop/section-2-c.c: New file.
* gfortran.dg/c-interop/section-2.f90: New file.
* gfortran.dg/c-interop/section-2p.f90: New file.
* gfortran.dg/c-interop/section-3-c.c: New file.
* gfortran.dg/c-interop/section-3.f90: New file.
* gfortran.dg/c-interop/section-3p.f90: New file.
* gfortran.dg/c-interop/section-4-c.c: New file.
* gfortran.dg/c-interop/section-4.f90: New file.
* gfortran.dg/c-interop/section-errors-c.c: New file.
* gfortran.dg/c-interop/section-errors.f90: New file.
* gfortran.dg/c-interop/select-c.c: New file.
* gfortran.dg/c-interop/select-errors-c.c: New file.
* gfortran.dg/c-interop/select-errors.f90: New file.
* gfortran.dg/c-interop/select.f90: New file.
* gfortran.dg/c-interop/setpointer-c.c: New file.
* gfortran.dg/c-interop/setpointer-errors-c.c: New file.
* gfortran.dg/c-interop/setpointer-errors.f90: New file.
* gfortran.dg/c-interop/setpointer.f90: New file.
* gfortran.dg/c-interop/shape.f90: New file.
* gfortran.dg/c-interop/size.f90: New file.
* gfortran.dg/c-interop/tkr.f90: New file.
* gfortran.dg/c-interop/typecodes-array-basic-c.c: New file.
* gfortran.dg/c-interop/typecodes-array-basic.f90: New file.
* gfortran.dg/c-interop/typecodes-array-char-c.c: New file.
* gfortran.dg/c-interop/typecodes-array-char.f90: New file.
* gfortran.dg/c-interop/typecodes-array-float128-c.c: New file.
* gfortran.dg/c-interop/typecodes-array-float128.f90: New file.
* gfortran.dg/c-interop/typecodes-array-int128-c.c: New file.
* gfortran.dg/c-interop/typecodes-array-int128.f90: New file.
* gfortran.dg/c-interop/typecodes-array-longdouble-c.c: New file.
* gfortran.dg/c-interop/typecodes-array-longdouble.f90: New file.
* gfortran.dg/c-interop/typecodes-sanity-c.c: New file.
* gfortran.dg/c-interop/typecodes-sanity.f90: New file.
* gfortran.dg/c-interop/typecodes-scalar-basic-c.c: New file.
* gfortran.dg/c-interop/typecodes-scalar-basic.f90: New file.
* gfortran.dg/c-interop/typecodes-scalar-float128-c.c: New file.
* gfortran.dg/c-interop/typecodes-scalar-float128.f90: New file.
* gfortran.dg/c-interop/typecodes-scalar-int128-c.c: New file.
* gfortran.dg/c-interop/typecodes-scalar-int128.f90: New file.
* gfortran.dg/c-interop/typecodes-scalar-longdouble-c.c: New file.
* gfortran.dg/c-interop/typecodes-scalar-longdouble.f90: New file.
* gfortran.dg/c-interop/ubound.f90: New file.
* lib/target-supports.exp
(check_effective_target_fortran_real_c_float128): New function.
(cherry picked from commit cb17b5054118ec0f727956fd6e034b577b5e261c)
Diff:
---
gcc/testsuite/ChangeLog.omp | 190 ++++++++++
.../gfortran.dg/c-interop/allocatable-dummy-c.c | 54 +++
.../gfortran.dg/c-interop/allocatable-dummy.f90 | 98 ++++++
.../c-interop/allocatable-optional-pointer.f90 | 23 ++
gcc/testsuite/gfortran.dg/c-interop/allocate-c.c | 168 +++++++++
.../gfortran.dg/c-interop/allocate-errors-c.c | 109 ++++++
.../gfortran.dg/c-interop/allocate-errors.f90 | 27 ++
gcc/testsuite/gfortran.dg/c-interop/allocate.f90 | 19 +
.../argument-association-assumed-rank-1.f90 | 31 ++
.../argument-association-assumed-rank-2.f90 | 48 +++
.../argument-association-assumed-rank-3.f90 | 51 +++
.../argument-association-assumed-rank-4.f90 | 50 +++
.../argument-association-assumed-rank-5.f90 | 31 ++
.../argument-association-assumed-rank-6.f90 | 48 +++
.../argument-association-assumed-rank-7.f90 | 51 +++
.../argument-association-assumed-rank-8.f90 | 50 +++
.../gfortran.dg/c-interop/assumed-type-dummy.f90 | 84 +++++
gcc/testsuite/gfortran.dg/c-interop/c-interop.exp | 57 +++
gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90 | 83 +++++
gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90 | 106 ++++++
gcc/testsuite/gfortran.dg/c-interop/c1255a.f90 | 40 +++
gcc/testsuite/gfortran.dg/c-interop/c407a-1.f90 | 55 +++
gcc/testsuite/gfortran.dg/c-interop/c407a-2.f90 | 88 +++++
gcc/testsuite/gfortran.dg/c-interop/c407b-1.f90 | 107 ++++++
gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90 | 150 ++++++++
gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90 | 63 ++++
gcc/testsuite/gfortran.dg/c-interop/c516.f90 | 67 ++++
gcc/testsuite/gfortran.dg/c-interop/c524a.f90 | 30 ++
gcc/testsuite/gfortran.dg/c-interop/c535a-1.f90 | 65 ++++
gcc/testsuite/gfortran.dg/c-interop/c535a-2.f90 | 78 +++++
gcc/testsuite/gfortran.dg/c-interop/c535b-1.f90 | 333 ++++++++++++++++++
gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90 | 387 +++++++++++++++++++++
gcc/testsuite/gfortran.dg/c-interop/c535b-3.f90 | 79 +++++
gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90 | 87 +++++
gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90 | 74 ++++
gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90 | 73 ++++
gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90 | 73 ++++
.../gfortran.dg/c-interop/cf-descriptor-1-c.c | 91 +++++
.../gfortran.dg/c-interop/cf-descriptor-1.f90 | 66 ++++
.../gfortran.dg/c-interop/cf-descriptor-2-c.c | 91 +++++
.../gfortran.dg/c-interop/cf-descriptor-2.f90 | 82 +++++
.../gfortran.dg/c-interop/cf-descriptor-3-c.c | 92 +++++
.../gfortran.dg/c-interop/cf-descriptor-3.f90 | 58 +++
.../gfortran.dg/c-interop/cf-descriptor-4-c.c | 112 ++++++
.../gfortran.dg/c-interop/cf-descriptor-4.f90 | 73 ++++
.../gfortran.dg/c-interop/cf-descriptor-5-c.c | 36 ++
.../gfortran.dg/c-interop/cf-descriptor-5.f90 | 31 ++
.../gfortran.dg/c-interop/cf-descriptor-6-c.c | 81 +++++
.../gfortran.dg/c-interop/cf-descriptor-6.f90 | 72 ++++
.../gfortran.dg/c-interop/cf-descriptor-7-c.c | 81 +++++
.../gfortran.dg/c-interop/cf-descriptor-7.f90 | 74 ++++
.../gfortran.dg/c-interop/cf-descriptor-8-c.c | 73 ++++
.../gfortran.dg/c-interop/cf-descriptor-8.f90 | 78 +++++
.../gfortran.dg/c-interop/cf-out-descriptor-1-c.c | 87 +++++
.../gfortran.dg/c-interop/cf-out-descriptor-1.f90 | 174 +++++++++
.../gfortran.dg/c-interop/cf-out-descriptor-2-c.c | 87 +++++
.../gfortran.dg/c-interop/cf-out-descriptor-2.f90 | 157 +++++++++
.../gfortran.dg/c-interop/cf-out-descriptor-3-c.c | 108 ++++++
.../gfortran.dg/c-interop/cf-out-descriptor-3.f90 | 134 +++++++
.../gfortran.dg/c-interop/cf-out-descriptor-4-c.c | 175 ++++++++++
.../gfortran.dg/c-interop/cf-out-descriptor-4.f90 | 207 +++++++++++
.../gfortran.dg/c-interop/cf-out-descriptor-5-c.c | 31 ++
.../gfortran.dg/c-interop/cf-out-descriptor-5.f90 | 48 +++
.../gfortran.dg/c-interop/cf-out-descriptor-6-c.c | 42 +++
.../gfortran.dg/c-interop/cf-out-descriptor-6.f90 | 115 ++++++
.../gfortran.dg/c-interop/contiguous-1-c.c | 56 +++
.../gfortran.dg/c-interop/contiguous-1.f90 | 67 ++++
.../gfortran.dg/c-interop/contiguous-2-c.c | 113 ++++++
.../gfortran.dg/c-interop/contiguous-2.f90 | 152 ++++++++
.../gfortran.dg/c-interop/contiguous-3-c.c | 80 +++++
.../gfortran.dg/c-interop/contiguous-3.f90 | 171 +++++++++
.../gfortran.dg/c-interop/deferred-character-1.f90 | 76 ++++
.../gfortran.dg/c-interop/deferred-character-2.f90 | 55 +++
.../gfortran.dg/c-interop/dump-descriptors.c | 195 +++++++++++
.../gfortran.dg/c-interop/dump-descriptors.h | 12 +
gcc/testsuite/gfortran.dg/c-interop/establish-c.c | 134 +++++++
.../gfortran.dg/c-interop/establish-errors-c.c | 120 +++++++
.../gfortran.dg/c-interop/establish-errors.f90 | 30 ++
gcc/testsuite/gfortran.dg/c-interop/establish.f90 | 35 ++
.../gfortran.dg/c-interop/explicit-interface.f90 | 60 ++++
.../gfortran.dg/c-interop/fc-descriptor-1-c.c | 46 +++
.../gfortran.dg/c-interop/fc-descriptor-1.f90 | 34 ++
.../gfortran.dg/c-interop/fc-descriptor-2-c.c | 68 ++++
.../gfortran.dg/c-interop/fc-descriptor-2.f90 | 40 +++
.../gfortran.dg/c-interop/fc-descriptor-3-c.c | 42 +++
.../gfortran.dg/c-interop/fc-descriptor-3.f90 | 37 ++
.../gfortran.dg/c-interop/fc-descriptor-4-c.c | 57 +++
.../gfortran.dg/c-interop/fc-descriptor-4.f90 | 36 ++
.../gfortran.dg/c-interop/fc-descriptor-5-c.c | 28 ++
.../gfortran.dg/c-interop/fc-descriptor-5.f90 | 35 ++
.../gfortran.dg/c-interop/fc-descriptor-6-c.c | 51 +++
.../gfortran.dg/c-interop/fc-descriptor-6.f90 | 50 +++
.../gfortran.dg/c-interop/fc-descriptor-7-c.c | 46 +++
.../gfortran.dg/c-interop/fc-descriptor-7.f90 | 37 ++
.../gfortran.dg/c-interop/fc-descriptor-8-c.c | 20 ++
.../gfortran.dg/c-interop/fc-descriptor-8.f90 | 22 ++
.../gfortran.dg/c-interop/fc-descriptor-9-c.c | 42 +++
.../gfortran.dg/c-interop/fc-descriptor-9.f90 | 23 ++
.../gfortran.dg/c-interop/fc-out-descriptor-1-c.c | 52 +++
.../gfortran.dg/c-interop/fc-out-descriptor-1.f90 | 66 ++++
.../gfortran.dg/c-interop/fc-out-descriptor-2-c.c | 52 +++
.../gfortran.dg/c-interop/fc-out-descriptor-2.f90 | 66 ++++
.../gfortran.dg/c-interop/fc-out-descriptor-3-c.c | 71 ++++
.../gfortran.dg/c-interop/fc-out-descriptor-3.f90 | 59 ++++
.../gfortran.dg/c-interop/fc-out-descriptor-4-c.c | 96 +++++
.../gfortran.dg/c-interop/fc-out-descriptor-4.f90 | 75 ++++
.../gfortran.dg/c-interop/fc-out-descriptor-5-c.c | 30 ++
.../gfortran.dg/c-interop/fc-out-descriptor-5.f90 | 35 ++
.../gfortran.dg/c-interop/fc-out-descriptor-6-c.c | 50 +++
.../gfortran.dg/c-interop/fc-out-descriptor-6.f90 | 49 +++
.../gfortran.dg/c-interop/fc-out-descriptor-7-c.c | 136 ++++++++
.../gfortran.dg/c-interop/fc-out-descriptor-7.f90 | 71 ++++
.../gfortran.dg/c-interop/ff-descriptor-1.f90 | 123 +++++++
.../gfortran.dg/c-interop/ff-descriptor-2.f90 | 97 ++++++
.../gfortran.dg/c-interop/ff-descriptor-3.f90 | 148 ++++++++
.../gfortran.dg/c-interop/ff-descriptor-4.f90 | 198 +++++++++++
.../gfortran.dg/c-interop/ff-descriptor-5.f90 | 61 ++++
.../gfortran.dg/c-interop/ff-descriptor-6.f90 | 71 ++++
.../gfortran.dg/c-interop/ff-descriptor-7.f90 | 89 +++++
gcc/testsuite/gfortran.dg/c-interop/note-5-3.f90 | 55 +++
gcc/testsuite/gfortran.dg/c-interop/note-5-4-c.c | 10 +
gcc/testsuite/gfortran.dg/c-interop/note-5-4.f90 | 63 ++++
gcc/testsuite/gfortran.dg/c-interop/optional-c.c | 82 +++++
gcc/testsuite/gfortran.dg/c-interop/optional.f90 | 114 ++++++
gcc/testsuite/gfortran.dg/c-interop/rank-class.f90 | 88 +++++
gcc/testsuite/gfortran.dg/c-interop/rank.f90 | 99 ++++++
.../c-interop/removed-restrictions-1.f90 | 41 +++
.../c-interop/removed-restrictions-2.f90 | 35 ++
.../c-interop/removed-restrictions-3.f90 | 37 ++
.../c-interop/removed-restrictions-4.f90 | 34 ++
gcc/testsuite/gfortran.dg/c-interop/section-1-c.c | 135 +++++++
gcc/testsuite/gfortran.dg/c-interop/section-1.f90 | 71 ++++
gcc/testsuite/gfortran.dg/c-interop/section-1p.f90 | 75 ++++
gcc/testsuite/gfortran.dg/c-interop/section-2-c.c | 175 ++++++++++
gcc/testsuite/gfortran.dg/c-interop/section-2.f90 | 102 ++++++
gcc/testsuite/gfortran.dg/c-interop/section-2p.f90 | 104 ++++++
gcc/testsuite/gfortran.dg/c-interop/section-3-c.c | 235 +++++++++++++
gcc/testsuite/gfortran.dg/c-interop/section-3.f90 | 103 ++++++
gcc/testsuite/gfortran.dg/c-interop/section-3p.f90 | 127 +++++++
gcc/testsuite/gfortran.dg/c-interop/section-4-c.c | 101 ++++++
gcc/testsuite/gfortran.dg/c-interop/section-4.f90 | 23 ++
.../gfortran.dg/c-interop/section-errors-c.c | 149 ++++++++
.../gfortran.dg/c-interop/section-errors.f90 | 27 ++
gcc/testsuite/gfortran.dg/c-interop/select-c.c | 138 ++++++++
.../gfortran.dg/c-interop/select-errors-c.c | 125 +++++++
.../gfortran.dg/c-interop/select-errors.f90 | 27 ++
gcc/testsuite/gfortran.dg/c-interop/select.f90 | 18 +
gcc/testsuite/gfortran.dg/c-interop/setpointer-c.c | 78 +++++
.../gfortran.dg/c-interop/setpointer-errors-c.c | 127 +++++++
.../gfortran.dg/c-interop/setpointer-errors.f90 | 28 ++
gcc/testsuite/gfortran.dg/c-interop/setpointer.f90 | 18 +
gcc/testsuite/gfortran.dg/c-interop/shape.f90 | 77 ++++
gcc/testsuite/gfortran.dg/c-interop/size.f90 | 106 ++++++
gcc/testsuite/gfortran.dg/c-interop/tkr.f90 | 46 +++
.../c-interop/typecodes-array-basic-c.c | 169 +++++++++
.../c-interop/typecodes-array-basic.f90 | 151 ++++++++
.../gfortran.dg/c-interop/typecodes-array-char-c.c | 35 ++
.../gfortran.dg/c-interop/typecodes-array-char.f90 | 37 ++
.../c-interop/typecodes-array-float128-c.c | 38 ++
.../c-interop/typecodes-array-float128.f90 | 34 ++
.../c-interop/typecodes-array-int128-c.c | 40 +++
.../c-interop/typecodes-array-int128.f90 | 33 ++
.../c-interop/typecodes-array-longdouble-c.c | 37 ++
.../c-interop/typecodes-array-longdouble.f90 | 32 ++
.../gfortran.dg/c-interop/typecodes-sanity-c.c | 179 ++++++++++
.../gfortran.dg/c-interop/typecodes-sanity.f90 | 24 ++
.../c-interop/typecodes-scalar-basic-c.c | 168 +++++++++
.../c-interop/typecodes-scalar-basic.f90 | 160 +++++++++
.../c-interop/typecodes-scalar-float128-c.c | 38 ++
.../c-interop/typecodes-scalar-float128.f90 | 34 ++
.../c-interop/typecodes-scalar-int128-c.c | 41 +++
.../c-interop/typecodes-scalar-int128.f90 | 35 ++
.../c-interop/typecodes-scalar-longdouble-c.c | 37 ++
.../c-interop/typecodes-scalar-longdouble.f90 | 33 ++
gcc/testsuite/gfortran.dg/c-interop/ubound.f90 | 129 +++++++
gcc/testsuite/lib/target-supports.exp | 16 +
176 files changed, 13921 insertions(+)
diff --git a/gcc/testsuite/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp
index f7e6526bcce..4dfef39ced8 100644
--- a/gcc/testsuite/ChangeLog.omp
+++ b/gcc/testsuite/ChangeLog.omp
@@ -1,3 +1,193 @@
+2021-09-17 Sandra Loosemore <sandra@codesourcery.com>
+
+ Backported from master:
+ 2021-09-02 Sandra Loosemore <sandra@codesourcery.com>
+
+ * gfortran.dg/c-interop/allocatable-dummy-c.c: New file.
+ * gfortran.dg/c-interop/allocatable-dummy.f90: New file.
+ * gfortran.dg/c-interop/allocatable-optional-pointer.f90: New file.
+ * gfortran.dg/c-interop/allocate-c.c: New file.
+ * gfortran.dg/c-interop/allocate-errors-c.c: New file.
+ * gfortran.dg/c-interop/allocate-errors.f90: New file.
+ * gfortran.dg/c-interop/allocate.f90: New file.
+ * gfortran.dg/c-interop/argument-association-assumed-rank-1.f90:
+ New file.
+ * gfortran.dg/c-interop/argument-association-assumed-rank-2.f90:
+ New file.
+ * gfortran.dg/c-interop/argument-association-assumed-rank-3.f90:
+ New file.
+ * gfortran.dg/c-interop/argument-association-assumed-rank-4.f90:
+ New file.
+ * gfortran.dg/c-interop/argument-association-assumed-rank-5.f90:
+ New file.
+ * gfortran.dg/c-interop/argument-association-assumed-rank-6.f90:
+ New file.
+ * gfortran.dg/c-interop/argument-association-assumed-rank-7.f90:
+ New file.
+ * gfortran.dg/c-interop/argument-association-assumed-rank-8.f90:
+ New file.
+ * gfortran.dg/c-interop/assumed-type-dummy.f90: New file.
+ * gfortran.dg/c-interop/c-interop.exp: New file.
+ * gfortran.dg/c-interop/c1255-1.f90: New file.
+ * gfortran.dg/c-interop/c1255-2.f90: New file.
+ * gfortran.dg/c-interop/c1255a.f90: New file.
+ * gfortran.dg/c-interop/c407a-1.f90: New file.
+ * gfortran.dg/c-interop/c407a-2.f90: New file.
+ * gfortran.dg/c-interop/c407b-1.f90: New file.
+ * gfortran.dg/c-interop/c407b-2.f90: New file.
+ * gfortran.dg/c-interop/c407c-1.f90: New file.
+ * gfortran.dg/c-interop/c516.f90: New file.
+ * gfortran.dg/c-interop/c524a.f90: New file.
+ * gfortran.dg/c-interop/c535a-1.f90: New file.
+ * gfortran.dg/c-interop/c535a-2.f90: New file.
+ * gfortran.dg/c-interop/c535b-1.f90: New file.
+ * gfortran.dg/c-interop/c535b-2.f90: New file.
+ * gfortran.dg/c-interop/c535b-3.f90: New file.
+ * gfortran.dg/c-interop/c535c-1.f90: New file.
+ * gfortran.dg/c-interop/c535c-2.f90: New file.
+ * gfortran.dg/c-interop/c535c-3.f90: New file.
+ * gfortran.dg/c-interop/c535c-4.f90: New file.
+ * gfortran.dg/c-interop/cf-descriptor-1-c.c: New file.
+ * gfortran.dg/c-interop/cf-descriptor-1.f90: New file.
+ * gfortran.dg/c-interop/cf-descriptor-2-c.c: New file.
+ * gfortran.dg/c-interop/cf-descriptor-2.f90: New file.
+ * gfortran.dg/c-interop/cf-descriptor-3-c.c: New file.
+ * gfortran.dg/c-interop/cf-descriptor-3.f90: New file.
+ * gfortran.dg/c-interop/cf-descriptor-4-c.c: New file.
+ * gfortran.dg/c-interop/cf-descriptor-4.f90: New file.
+ * gfortran.dg/c-interop/cf-descriptor-5-c.c: New file.
+ * gfortran.dg/c-interop/cf-descriptor-5.f90: New file.
+ * gfortran.dg/c-interop/cf-descriptor-6-c.c: New file.
+ * gfortran.dg/c-interop/cf-descriptor-6.f90: New file.
+ * gfortran.dg/c-interop/cf-descriptor-7-c.c: New file.
+ * gfortran.dg/c-interop/cf-descriptor-7.f90: New file.
+ * gfortran.dg/c-interop/cf-descriptor-8-c.c: New file.
+ * gfortran.dg/c-interop/cf-descriptor-8.f90: New file.
+ * gfortran.dg/c-interop/cf-out-descriptor-1-c.c: New file.
+ * gfortran.dg/c-interop/cf-out-descriptor-1.f90: New file.
+ * gfortran.dg/c-interop/cf-out-descriptor-2-c.c: New file.
+ * gfortran.dg/c-interop/cf-out-descriptor-2.f90: New file.
+ * gfortran.dg/c-interop/cf-out-descriptor-3-c.c: New file.
+ * gfortran.dg/c-interop/cf-out-descriptor-3.f90: New file.
+ * gfortran.dg/c-interop/cf-out-descriptor-4-c.c: New file.
+ * gfortran.dg/c-interop/cf-out-descriptor-4.f90: New file.
+ * gfortran.dg/c-interop/cf-out-descriptor-5-c.c: New file.
+ * gfortran.dg/c-interop/cf-out-descriptor-5.f90: New file.
+ * gfortran.dg/c-interop/cf-out-descriptor-6-c.c: New file.
+ * gfortran.dg/c-interop/cf-out-descriptor-6.f90: New file.
+ * gfortran.dg/c-interop/contiguous-1-c.c: New file.
+ * gfortran.dg/c-interop/contiguous-1.f90: New file.
+ * gfortran.dg/c-interop/contiguous-2-c.c: New file.
+ * gfortran.dg/c-interop/contiguous-2.f90: New file.
+ * gfortran.dg/c-interop/contiguous-3-c.c: New file.
+ * gfortran.dg/c-interop/contiguous-3.f90: New file.
+ * gfortran.dg/c-interop/deferred-character-1.f90: New file.
+ * gfortran.dg/c-interop/deferred-character-2.f90: New file.
+ * gfortran.dg/c-interop/dump-descriptors.c: New file.
+ * gfortran.dg/c-interop/dump-descriptors.h: New file.
+ * gfortran.dg/c-interop/establish-c.c: New file.
+ * gfortran.dg/c-interop/establish-errors-c.c: New file.
+ * gfortran.dg/c-interop/establish-errors.f90: New file.
+ * gfortran.dg/c-interop/establish.f90: New file.
+ * gfortran.dg/c-interop/explicit-interface.f90: New file.
+ * gfortran.dg/c-interop/fc-descriptor-1-c.c: New file.
+ * gfortran.dg/c-interop/fc-descriptor-1.f90: New file.
+ * gfortran.dg/c-interop/fc-descriptor-2-c.c: New file.
+ * gfortran.dg/c-interop/fc-descriptor-2.f90: New file.
+ * gfortran.dg/c-interop/fc-descriptor-3-c.c: New file.
+ * gfortran.dg/c-interop/fc-descriptor-3.f90: New file.
+ * gfortran.dg/c-interop/fc-descriptor-4-c.c: New file.
+ * gfortran.dg/c-interop/fc-descriptor-4.f90: New file.
+ * gfortran.dg/c-interop/fc-descriptor-5-c.c: New file.
+ * gfortran.dg/c-interop/fc-descriptor-5.f90: New file.
+ * gfortran.dg/c-interop/fc-descriptor-6-c.c: New file.
+ * gfortran.dg/c-interop/fc-descriptor-6.f90: New file.
+ * gfortran.dg/c-interop/fc-descriptor-7-c.c: New file.
+ * gfortran.dg/c-interop/fc-descriptor-7.f90: New file.
+ * gfortran.dg/c-interop/fc-descriptor-8-c.c: New file.
+ * gfortran.dg/c-interop/fc-descriptor-8.f90: New file.
+ * gfortran.dg/c-interop/fc-descriptor-9-c.c: New file.
+ * gfortran.dg/c-interop/fc-descriptor-9.f90: New file.
+ * gfortran.dg/c-interop/fc-out-descriptor-1-c.c: New file.
+ * gfortran.dg/c-interop/fc-out-descriptor-1.f90: New file.
+ * gfortran.dg/c-interop/fc-out-descriptor-2-c.c: New file.
+ * gfortran.dg/c-interop/fc-out-descriptor-2.f90: New file.
+ * gfortran.dg/c-interop/fc-out-descriptor-3-c.c: New file.
+ * gfortran.dg/c-interop/fc-out-descriptor-3.f90: New file.
+ * gfortran.dg/c-interop/fc-out-descriptor-4-c.c: New file.
+ * gfortran.dg/c-interop/fc-out-descriptor-4.f90: New file.
+ * gfortran.dg/c-interop/fc-out-descriptor-5-c.c: New file.
+ * gfortran.dg/c-interop/fc-out-descriptor-5.f90: New file.
+ * gfortran.dg/c-interop/fc-out-descriptor-6-c.c: New file.
+ * gfortran.dg/c-interop/fc-out-descriptor-6.f90: New file.
+ * gfortran.dg/c-interop/fc-out-descriptor-7-c.c: New file.
+ * gfortran.dg/c-interop/fc-out-descriptor-7.f90: New file.
+ * gfortran.dg/c-interop/ff-descriptor-1.f90: New file.
+ * gfortran.dg/c-interop/ff-descriptor-2.f90: New file.
+ * gfortran.dg/c-interop/ff-descriptor-3.f90: New file.
+ * gfortran.dg/c-interop/ff-descriptor-4.f90: New file.
+ * gfortran.dg/c-interop/ff-descriptor-5.f90: New file.
+ * gfortran.dg/c-interop/ff-descriptor-6.f90: New file.
+ * gfortran.dg/c-interop/ff-descriptor-7.f90: New file.
+ * gfortran.dg/c-interop/note-5-3.f90: New file.
+ * gfortran.dg/c-interop/note-5-4-c.c: New file.
+ * gfortran.dg/c-interop/note-5-4.f90: New file.
+ * gfortran.dg/c-interop/optional-c.c: New file.
+ * gfortran.dg/c-interop/optional.f90: New file.
+ * gfortran.dg/c-interop/rank-class.f90: New file.
+ * gfortran.dg/c-interop/rank.f90: New file.
+ * gfortran.dg/c-interop/removed-restrictions-1.f90: New file.
+ * gfortran.dg/c-interop/removed-restrictions-2.f90: New file.
+ * gfortran.dg/c-interop/removed-restrictions-3.f90: New file.
+ * gfortran.dg/c-interop/removed-restrictions-4.f90: New file.
+ * gfortran.dg/c-interop/section-1-c.c: New file.
+ * gfortran.dg/c-interop/section-1.f90: New file.
+ * gfortran.dg/c-interop/section-1p.f90: New file.
+ * gfortran.dg/c-interop/section-2-c.c: New file.
+ * gfortran.dg/c-interop/section-2.f90: New file.
+ * gfortran.dg/c-interop/section-2p.f90: New file.
+ * gfortran.dg/c-interop/section-3-c.c: New file.
+ * gfortran.dg/c-interop/section-3.f90: New file.
+ * gfortran.dg/c-interop/section-3p.f90: New file.
+ * gfortran.dg/c-interop/section-4-c.c: New file.
+ * gfortran.dg/c-interop/section-4.f90: New file.
+ * gfortran.dg/c-interop/section-errors-c.c: New file.
+ * gfortran.dg/c-interop/section-errors.f90: New file.
+ * gfortran.dg/c-interop/select-c.c: New file.
+ * gfortran.dg/c-interop/select-errors-c.c: New file.
+ * gfortran.dg/c-interop/select-errors.f90: New file.
+ * gfortran.dg/c-interop/select.f90: New file.
+ * gfortran.dg/c-interop/setpointer-c.c: New file.
+ * gfortran.dg/c-interop/setpointer-errors-c.c: New file.
+ * gfortran.dg/c-interop/setpointer-errors.f90: New file.
+ * gfortran.dg/c-interop/setpointer.f90: New file.
+ * gfortran.dg/c-interop/shape.f90: New file.
+ * gfortran.dg/c-interop/size.f90: New file.
+ * gfortran.dg/c-interop/tkr.f90: New file.
+ * gfortran.dg/c-interop/typecodes-array-basic-c.c: New file.
+ * gfortran.dg/c-interop/typecodes-array-basic.f90: New file.
+ * gfortran.dg/c-interop/typecodes-array-char-c.c: New file.
+ * gfortran.dg/c-interop/typecodes-array-char.f90: New file.
+ * gfortran.dg/c-interop/typecodes-array-float128-c.c: New file.
+ * gfortran.dg/c-interop/typecodes-array-float128.f90: New file.
+ * gfortran.dg/c-interop/typecodes-array-int128-c.c: New file.
+ * gfortran.dg/c-interop/typecodes-array-int128.f90: New file.
+ * gfortran.dg/c-interop/typecodes-array-longdouble-c.c: New file.
+ * gfortran.dg/c-interop/typecodes-array-longdouble.f90: New file.
+ * gfortran.dg/c-interop/typecodes-sanity-c.c: New file.
+ * gfortran.dg/c-interop/typecodes-sanity.f90: New file.
+ * gfortran.dg/c-interop/typecodes-scalar-basic-c.c: New file.
+ * gfortran.dg/c-interop/typecodes-scalar-basic.f90: New file.
+ * gfortran.dg/c-interop/typecodes-scalar-float128-c.c: New file.
+ * gfortran.dg/c-interop/typecodes-scalar-float128.f90: New file.
+ * gfortran.dg/c-interop/typecodes-scalar-int128-c.c: New file.
+ * gfortran.dg/c-interop/typecodes-scalar-int128.f90: New file.
+ * gfortran.dg/c-interop/typecodes-scalar-longdouble-c.c: New file.
+ * gfortran.dg/c-interop/typecodes-scalar-longdouble.f90: New file.
+ * gfortran.dg/c-interop/ubound.f90: New file.
+ * lib/target-supports.exp
+ (check_effective_target_fortran_real_c_float128): New function.
+
2021-09-17 Tobias Burnus <tobias@codesourcery.com>
Backported from master:
diff --git a/gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy-c.c b/gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy-c.c
new file mode 100644
index 00000000000..0ed09b5043f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy-c.c
@@ -0,0 +1,54 @@
+#include <stdlib.h>
+#include <stddef.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+struct t {
+ float xyz[3];
+ int id;
+};
+
+extern void testit_f_bind_c (CFI_cdesc_t *a, float x, float y, float z);
+extern void testit_c (CFI_cdesc_t *a, float x, float y, float z);
+
+void testit_c (CFI_cdesc_t *a, float x, float y, float z)
+{
+ struct t *tp;
+
+ /* Check that the allocatable dummy is unallocated on entry and do
+ some other sanity checks. */
+ dump_CFI_cdesc_t (a);
+ if (a->attribute != CFI_attribute_allocatable)
+ abort ();
+ if (a->rank)
+ abort ();
+ if (a->base_addr)
+ abort ();
+
+ /* Allocate and initialize the output argument. */
+ CFI_allocate (a, NULL, NULL, 0);
+ if (!a->base_addr)
+ abort ();
+ tp = (struct t *) CFI_address (a, NULL);
+ tp->id = 42;
+ tp->xyz[0] = 0.0;
+ tp->xyz[1] = 0.0;
+ tp->xyz[2] = 0.0;
+
+ /* Now call the Fortran function, which is supposed to automatically
+ deallocate the object we just created above and point the descriptor
+ at a different object. */
+ testit_f_bind_c (a, x, y, z);
+
+ /* Make sure we've got an allocated object, initialized as we
+ expect. */
+ if (!a->base_addr)
+ abort ();
+ tp = (struct t *) CFI_address (a, NULL);
+ if (tp->id != -1)
+ abort ();
+ if (tp->xyz[0] != x || tp->xyz[1] != y || tp->xyz[2] != z)
+ abort ();
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy.f90 b/gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy.f90
new file mode 100644
index 00000000000..4161a30b16a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy.f90
@@ -0,0 +1,98 @@
+! PR 101308
+! PR 92621(?)
+! { dg-do run { xfail *-*-* } }
+! { dg-additional-sources "allocatable-dummy-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! TS 29113
+! 6.3 Argument association
+!
+! When a Fortran procedure that has an INTENT(OUT) allocatable dummy
+! argument is invoked by a C function, and the actual argument in the C
+! function is the address of a C descriptor that describes an allocated
+! allocatable variable, the variable is deallocated on entry to the
+! Fortran procedure.
+
+! When a C function is invoked from a Fortran procedure via an interface
+! with an INTENT(OUT) allocatable dummy argument, and the actual
+! argument in the reference to the C function is an allocated
+! allocatable variable, the variable is deallocated on invocation
+! (before execution of the C function begins).
+
+module m
+ use iso_c_binding
+
+ type, bind (c) :: t
+ real(C_FLOAT) :: xyz(3)
+ integer(C_INT) :: id
+ end type
+
+ interface
+ subroutine testit_c (a, x, y, z) bind (c)
+ use iso_c_binding
+ import :: t
+ type (t), allocatable, intent(out) :: a
+ real(C_FLOAT), value, intent(in) :: x, y, z
+ end subroutine
+ end interface
+
+ contains
+
+ subroutine testit_f (a, x, y, z)
+ type (t), allocatable, intent(out) :: a
+ real(C_FLOAT), value, intent(in) :: x, y, z
+ if (allocated (a)) stop 201
+ allocate (a)
+ a%id = 69
+ a%xyz(1) = x
+ a%xyz(2) = y
+ a%xyz(3) = z
+ end subroutine
+
+ subroutine testit_f_bind_c (a, x, y, z) bind (c)
+ type (t), allocatable, intent(out) :: a
+ real(C_FLOAT), value, intent(in) :: x, y, z
+ if (allocated (a)) stop 301
+ allocate (a)
+ a%id = -1
+ a%xyz(1) = x
+ a%xyz(2) = y
+ a%xyz(3) = z
+ end subroutine
+
+end module
+
+program test
+ use iso_c_binding
+ use m
+
+ type (t), allocatable :: b
+
+ if (allocated (b)) stop 401
+
+ ! Try the regular Fortran test routine.
+ allocate (b)
+ call testit_f (b, 1.0, 2.0, 3.0)
+ if (.not. allocated (b)) stop 402
+ deallocate (b)
+ if (allocated (b)) stop 403
+
+ ! Try the test routine written in Fortran with C binding.
+ allocate (b)
+ call testit_f_bind_c (b, 1.0, 2.0, 3.0)
+ if (.not. allocated (b)) stop 404
+ deallocate (b)
+ if (allocated (b)) stop 405
+
+ ! Try the test routine written in C. This calls testit_f_bind_c
+ ! before returning, so make sure that's what we've got when returning.
+ allocate (b)
+ call testit_c (b, -1.0, -2.0, -3.0)
+ if (.not. allocated (b)) stop 406
+ if (b%id .ne. -1) stop 407
+ if (b%xyz(1) .ne. -1.0) stop 408
+ if (b%xyz(2) .ne. -2.0) stop 408
+ if (b%xyz(3) .ne. -3.0) stop 408
+ deallocate (b)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/allocatable-optional-pointer.f90 b/gcc/testsuite/gfortran.dg/c-interop/allocatable-optional-pointer.f90
new file mode 100644
index 00000000000..5a785b8a94d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/allocatable-optional-pointer.f90
@@ -0,0 +1,23 @@
+! { dg-do compile}
+!
+! TS 29113
+! 5.3 ALLOCATABLE, OPTIONAL, and POINTER attributes
+! The ALLOCATABLE, OPTIONAL, and POINTER attributes may be specified
+! for a dummy argument in a procedure interface that has the BIND
+! attribute.
+
+subroutine test (a, b, c)
+ integer, allocatable :: a
+ integer, optional :: b
+ integer, pointer :: c
+
+ interface
+ subroutine ctest (aa, bb, cc) bind (c)
+ integer, allocatable :: aa
+ integer, optional :: bb
+ integer, pointer :: cc
+ end subroutine
+ end interface
+
+ call ctest (a, b, c)
+end subroutine
diff --git a/gcc/testsuite/gfortran.dg/c-interop/allocate-c.c b/gcc/testsuite/gfortran.dg/c-interop/allocate-c.c
new file mode 100644
index 00000000000..ed2d84f91a4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/allocate-c.c
@@ -0,0 +1,168 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+struct s {
+ int i;
+ double d;
+};
+
+/* External entry point. */
+extern void ctest (void);
+
+void
+ctest (void)
+{
+ CFI_CDESC_T(3) desc;
+ CFI_cdesc_t *dv = (CFI_cdesc_t *) &desc;
+ CFI_index_t ex[3], lb[3], ub[3];
+ CFI_index_t sm;
+ int i;
+
+ /* Allocate and deallocate a scalar. */
+ sm = sizeof (struct s);
+ check_CFI_status ("CFI_establish",
+ CFI_establish (dv, NULL, CFI_attribute_allocatable,
+ CFI_type_struct, sm,
+ 0, NULL));
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (dv, NULL, NULL, 69));
+ dump_CFI_cdesc_t (dv);
+ if (dv->base_addr == NULL)
+ abort ();
+ /* The elem_len argument only overrides the initial value in the
+ descriptor for character types. */
+ if (dv->elem_len != sm)
+ abort ();
+ check_CFI_status ("CFI_deallocate",
+ CFI_deallocate (dv));
+ /* The base_addr member of the C descriptor becomes a null pointer. */
+ if (dv->base_addr != NULL)
+ abort ();
+
+ /* Try an array. We are going to test the requirement that:
+ The supplied lower and upper bounds override any current
+ dimension information in the C descriptor.
+ so we'll stuff different values in the descriptor to start with. */
+ ex[0] = 3;
+ ex[1] = 4;
+ ex[2] = 5;
+ check_CFI_status ("CFI_establish",
+ CFI_establish (dv, NULL, CFI_attribute_pointer,
+ CFI_type_double, 0, 3, ex));
+ lb[0] = 1;
+ lb[1] = 2;
+ lb[2] = 3;
+ ub[0] = 10;
+ ub[1] = 5;
+ ub[2] = 10;
+ sm = sizeof (double);
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (dv, lb, ub, 20));
+ dump_CFI_cdesc_t (dv);
+ if (dv->base_addr == NULL)
+ abort ();
+ /* The element sizes passed to both CFI_establish and CFI_allocate should
+ have been ignored in favor of using the constant size of the type. */
+ if (dv->elem_len != sm)
+ abort ();
+
+ /* Check extents and strides; we expect the allocated array to
+ be contiguous so the stride computation should be straightforward
+ no matter what the lower bound is. */
+ for (i = 0; i < 3; i++)
+ {
+ CFI_index_t extent = ub[i] - lb[i] + 1;
+ if (dv->dim[i].lower_bound != lb[i])
+ abort ();
+ if (dv->dim[i].extent != extent)
+ abort ();
+ /* pr93524 */
+ if (dv->dim[i].sm != sm)
+ abort ();
+ sm *= extent;
+ }
+ check_CFI_status ("CFI_deallocate",
+ CFI_deallocate (dv));
+ if (dv->base_addr != NULL)
+ abort ();
+
+ /* Similarly for a character array, except that we expect the
+ elem_len provided to CFI_allocate to prevail. We set the elem_len
+ to the same size as the array element in the previous example, so
+ the bounds and strides should all be the same. */
+ ex[0] = 3;
+ ex[1] = 4;
+ ex[2] = 5;
+ check_CFI_status ("CFI_establish",
+ CFI_establish (dv, NULL, CFI_attribute_allocatable,
+ CFI_type_char, 4, 3, ex));
+ lb[0] = 1;
+ lb[1] = 2;
+ lb[2] = 3;
+ ub[0] = 10;
+ ub[1] = 5;
+ ub[2] = 10;
+ sm = sizeof (double);
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (dv, lb, ub, sm));
+ dump_CFI_cdesc_t (dv);
+ if (dv->base_addr == NULL)
+ abort ();
+ if (dv->elem_len != sm)
+ abort ();
+
+ /* Check extents and strides; we expect the allocated array to
+ be contiguous so the stride computation should be straightforward
+ no matter what the lower bound is. */
+ for (i = 0; i < 3; i++)
+ {
+ CFI_index_t extent = ub[i] - lb[i] + 1;
+ if (dv->dim[i].lower_bound != lb[i])
+ abort ();
+ if (dv->dim[i].extent != extent)
+ abort ();
+ /* pr93524 */
+ if (dv->dim[i].sm != sm)
+ abort ();
+ sm *= extent;
+ }
+ check_CFI_status ("CFI_deallocate",
+ CFI_deallocate (dv));
+ if (dv->base_addr != NULL)
+ abort ();
+
+ /* Signed char is not a Fortran character type. Here we expect it to
+ ignore the elem_len argument and use the size of the type. */
+ ex[0] = 3;
+ ex[1] = 4;
+ ex[2] = 5;
+ check_CFI_status ("CFI_establish",
+ CFI_establish (dv, NULL, CFI_attribute_allocatable,
+ CFI_type_signed_char, 4, 3, ex));
+ lb[0] = 1;
+ lb[1] = 2;
+ lb[2] = 3;
+ ub[0] = 10;
+ ub[1] = 5;
+ ub[2] = 10;
+ sm = sizeof (double);
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (dv, lb, ub, sm));
+ dump_CFI_cdesc_t (dv);
+ if (dv->base_addr == NULL)
+ abort ();
+ if (dv->elem_len != sizeof (signed char))
+ abort ();
+
+ check_CFI_status ("CFI_deallocate",
+ CFI_deallocate (dv));
+ if (dv->base_addr != NULL)
+ abort ();
+
+}
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/allocate-errors-c.c b/gcc/testsuite/gfortran.dg/c-interop/allocate-errors-c.c
new file mode 100644
index 00000000000..3a81049ab15
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/allocate-errors-c.c
@@ -0,0 +1,109 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+struct s {
+ int i;
+ double d;
+};
+
+static long buf[5][4][3];
+
+/* External entry point. */
+extern void ctest (void);
+
+void
+ctest (void)
+{
+ int bad = 0;
+ int status;
+ CFI_CDESC_T(3) desc;
+ CFI_cdesc_t *dv = (CFI_cdesc_t *) &desc;
+ CFI_index_t ex[3], lb[3], ub[3];
+ CFI_index_t sm;
+
+ /* On entry, the base_addr member of the C descriptor shall be a null
+ pointer. */
+ sm = sizeof (struct s);
+ check_CFI_status ("CFI_establish",
+ CFI_establish (dv, NULL, CFI_attribute_allocatable,
+ CFI_type_struct, sm,
+ 0, NULL));
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (dv, NULL, NULL, 69));
+ status = CFI_allocate (dv, NULL, NULL, 42);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for CFI_allocate of already-allocated object\n");
+ bad ++;
+ }
+ check_CFI_status ("CFI_deallocate",
+ CFI_deallocate (dv));
+
+ /* The attribute member of the C descriptor shall have a value of
+ CFI_attribute_allocatable or CFI_attribute_pointer. */
+ ex[0] = 3;
+ ex[1] = 4;
+ ex[2] = 5;
+ check_CFI_status ("CFI_establish",
+ CFI_establish (dv, NULL, CFI_attribute_other,
+ CFI_type_long, 0, 3, ex));
+ lb[0] = 1;
+ lb[1] = 2;
+ lb[2] = 3;
+ ub[0] = 10;
+ ub[1] = 5;
+ ub[2] = 10;
+ sm = sizeof (long);
+ status = CFI_allocate (dv, lb, ub, 20);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for CFI_allocate of CFI_attribute_other object\n");
+ bad ++;
+ }
+
+ /* dv shall be the address of a C descriptor describing the object.
+ It shall have been allocated using the same mechanism as the
+ Fortran ALLOCATE statement. */
+ ex[0] = 3;
+ ex[1] = 4;
+ ex[2] = 5;
+ check_CFI_status ("CFI_establish",
+ CFI_establish (dv, NULL, CFI_attribute_pointer,
+ CFI_type_long, 0, 3, ex));
+ status = CFI_deallocate (dv);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for CFI_deallocate with null pointer\n");
+ bad ++;
+ }
+
+ /* This variant is disabled. In theory it should be possible for
+ the memory allocator to easily check for pointers outside the
+ heap region, but libfortran just calls free() which has no provision
+ for returning an error, and there is no other standard C interface
+ to check the validity of a pointer in the C heap either. */
+#if 0
+ check_CFI_status ("CFI_establish",
+ CFI_establish (dv, buf, CFI_attribute_pointer,
+ CFI_type_long, 0, 3, ex));
+ status = CFI_deallocate (dv);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for CFI_deallocate with non-allocated pointer\n");
+ bad ++;
+ }
+#endif
+
+ if (bad)
+ abort ();
+}
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/allocate-errors.f90 b/gcc/testsuite/gfortran.dg/c-interop/allocate-errors.f90
new file mode 100644
index 00000000000..a58d05a3368
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/allocate-errors.f90
@@ -0,0 +1,27 @@
+! { dg-do run }
+! { dg-additional-sources "allocate-errors-c.c dump-descriptors.c" }
+! { dg-additional-options "-Wno-error -fcheck=all" }
+! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 }
+!
+! This program tests that the CFI_allocate and CFI_deallocate functions
+! properly detect invalid arguments. All the interesting things happen
+! in the corresponding C code.
+!
+! The situation here seems to be that while TS29113 defines error codes for
+! these functions, it doesn't actually require the implementation to detect
+! those errors by saying the arguments "shall be" such-and-such, e.g. it is
+! undefined behavior if they are not. In gfortran you can enable some
+! run-time checking by building with -fcheck=all.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest () bind (c)
+ end subroutine
+ end interface
+
+ call ctest ()
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/allocate.f90 b/gcc/testsuite/gfortran.dg/c-interop/allocate.f90
new file mode 100644
index 00000000000..6878f042172
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/allocate.f90
@@ -0,0 +1,19 @@
+! { dg-do run }
+! { dg-additional-sources "allocate-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests the CFI_allocate and CFI_deallocate functions.
+! All the interesting things happen in the corresponding C code.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest () bind (c)
+ end subroutine
+ end interface
+
+ call ctest ()
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-1.f90
new file mode 100644
index 00000000000..ee06cc77b63
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-1.f90
@@ -0,0 +1,31 @@
+! { dg-do run }
+!
+! TS 29113
+! 6.3 Argument association
+! An assumed-rank dummy argument may correspond to an actual argument of
+! any rank. If the actual argument has rank zero, the dummy argument has
+! rank zero; the shape is a zero-sized array and the LBOUND and UBOUND
+! intrinsic functions, with no DIM argument, return zero-sized
+! arrays. [...]
+
+program test
+
+ call testit (42)
+
+contains
+
+ subroutine testit (x0)
+ integer :: x0(..)
+
+ ! expect to have rank 0
+ if (rank (x0) .ne. 0) stop 101
+
+ ! expect shape to be a zero-sized array
+ if (size (shape (x0)) .ne. 0) stop 102
+
+ ! expect lbound and ubound functions to return zero-sized arrays
+ if (size (lbound (x0)) .ne. 0) stop 103
+ if (size (ubound (x0)) .ne. 0) stop 104
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-2.f90
new file mode 100644
index 00000000000..4beeb8120c7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-2.f90
@@ -0,0 +1,48 @@
+! { dg-do run }
+!
+! TS 29113
+! 6.3 Argument association
+! An assumed-rank dummy argument may correspond to an actual argument of
+! any rank. [...] If the actual argument has rank greater than zero, the
+! rank and extents of the dummy argument are assumed from the actual
+! argument, including the lack of a final extent in the case of an
+! assumed-size array. If the actual argument is an array and the dummy
+! argument is allocatable or a pointer, the bounds of the dummy argument
+! are assumed from the actual argument.
+
+program test
+
+ integer :: a(3, 4, 5)
+ integer :: b(-3:3, 0:4, 2:5, 10:20)
+
+ call testit (a, rank(a), shape(a), lbound(a), ubound(a))
+ call testit (b, rank(b), shape(b), lbound(b), ubound(b))
+
+contains
+
+ subroutine testit (x, r, s, l, u)
+ integer :: x(..)
+ integer :: r
+ integer :: s(r)
+ integer :: l(r)
+ integer :: u(r)
+
+ ! expect rank to match
+ if (rank (x) .ne. r) stop 101
+
+ ! expect shape to match
+ if (size (shape (x)) .ne. r) stop 102
+ if (any (shape (x) .ne. s)) stop 103
+
+ ! expect lbound and ubound functions to return rank-sized arrays.
+ ! for non-pointer/non-allocatable arrays, bounds are normalized
+ ! to be 1-based.
+ if (size (lbound (x)) .ne. r) stop 104
+ if (any (lbound (x) .ne. 1)) stop 105
+
+ if (size (ubound (x)) .ne. r) stop 106
+ if (any (ubound (x) .ne. u - l + 1)) stop 107
+ if (any (ubound (x) .ne. s)) stop 108
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-3.f90
new file mode 100644
index 00000000000..c4b10100496
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-3.f90
@@ -0,0 +1,51 @@
+! { dg-do run }
+!
+! TS 29113
+! 6.3 Argument association
+! An assumed-rank dummy argument may correspond to an actual argument of
+! any rank. [...] If the actual argument has rank greater than zero, the
+! rank and extents of the dummy argument are assumed from the actual
+! argument, including the lack of a final extent in the case of an
+! assumed-size array. If the actual argument is an array and the dummy
+! argument is allocatable or a pointer, the bounds of the dummy argument
+! are assumed from the actual argument.
+
+program test
+
+ integer, target :: a(3, 4, 5)
+ integer, target :: b(-3:3, 0:4, 2:5, 10:20)
+ integer, pointer :: aa(:,:,:)
+ integer, pointer :: bb(:,:,:,:)
+ aa => a
+ bb => b
+
+ call testit (aa, rank(a), shape(a), lbound(a), ubound(a))
+ call testit (bb, rank(b), shape(b), lbound(b), ubound(b))
+
+contains
+
+ subroutine testit (x, r, s, l, u)
+ integer, pointer :: x(..)
+ integer :: r
+ integer :: s(r)
+ integer :: l(r)
+ integer :: u(r)
+
+ ! expect rank to match
+ if (rank (x) .ne. r) stop 101
+
+ ! expect shape to match
+ if (size (shape (x)) .ne. r) stop 102
+ if (any (shape (x) .ne. s)) stop 103
+
+ ! expect lbound and ubound functions to return rank-sized arrays.
+ ! for non-pointer/non-allocatable arrays, bounds are normalized
+ ! to be 1-based.
+ if (size (lbound (x)) .ne. r) stop 104
+ if (any (lbound (x) .ne. l)) stop 105
+
+ if (size (ubound (x)) .ne. r) stop 106
+ if (any (ubound (x) .ne. u)) stop 107
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-4.f90
new file mode 100644
index 00000000000..9c92718fc7f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-4.f90
@@ -0,0 +1,50 @@
+! { dg-do run }
+!
+! TS 29113
+! 6.3 Argument association
+! An assumed-rank dummy argument may correspond to an actual argument of
+! any rank. [...] If the actual argument has rank greater than zero, the
+! rank and extents of the dummy argument are assumed from the actual
+! argument, including the lack of a final extent in the case of an
+! assumed-size array. If the actual argument is an array and the dummy
+! argument is allocatable or a pointer, the bounds of the dummy argument
+! are assumed from the actual argument.
+
+program test
+
+ integer, allocatable :: a(:,:,:)
+ integer, allocatable :: b(:,:,:,:)
+
+ allocate (a(3, 4, 5))
+ allocate (b(-3:3, 0:4, 2:5, 10:20))
+
+ call testit (a, rank(a), shape(a), lbound(a), ubound(a))
+ call testit (b, rank(b), shape(b), lbound(b), ubound(b))
+
+contains
+
+ subroutine testit (x, r, s, l, u)
+ integer, allocatable :: x(..)
+ integer :: r
+ integer :: s(r)
+ integer :: l(r)
+ integer :: u(r)
+
+ ! expect rank to match
+ if (rank (x) .ne. r) stop 101
+
+ ! expect shape to match
+ if (size (shape (x)) .ne. r) stop 102
+ if (any (shape (x) .ne. s)) stop 103
+
+ ! expect lbound and ubound functions to return rank-sized arrays.
+ ! for non-pointer/non-allocatable arrays, bounds are normalized
+ ! to be 1-based.
+ if (size (lbound (x)) .ne. r) stop 104
+ if (any (lbound (x) .ne. l)) stop 105
+
+ if (size (ubound (x)) .ne. r) stop 106
+ if (any (ubound (x) .ne. u)) stop 107
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-5.f90
new file mode 100644
index 00000000000..fd87225faef
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-5.f90
@@ -0,0 +1,31 @@
+! { dg-do run }
+!
+! TS 29113
+! 6.3 Argument association
+! An assumed-rank dummy argument may correspond to an actual argument of
+! any rank. If the actual argument has rank zero, the dummy argument has
+! rank zero; the shape is a zero-sized array and the LBOUND and UBOUND
+! intrinsic functions, with no DIM argument, return zero-sized
+! arrays. [...]
+
+program test
+
+ call testit (42)
+
+contains
+
+ subroutine testit (x0) bind (c)
+ integer :: x0(..)
+
+ ! expect to have rank 0
+ if (rank (x0) .ne. 0) stop 101
+
+ ! expect shape to be a zero-sized array
+ if (size (shape (x0)) .ne. 0) stop 102
+
+ ! expect lbound and ubound functions to return zero-sized arrays
+ if (size (lbound (x0)) .ne. 0) stop 103
+ if (size (ubound (x0)) .ne. 0) stop 104
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-6.f90
new file mode 100644
index 00000000000..a65d4368252
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-6.f90
@@ -0,0 +1,48 @@
+! { dg-do run }
+!
+! TS 29113
+! 6.3 Argument association
+! An assumed-rank dummy argument may correspond to an actual argument of
+! any rank. [...] If the actual argument has rank greater than zero, the
+! rank and extents of the dummy argument are assumed from the actual
+! argument, including the lack of a final extent in the case of an
+! assumed-size array. If the actual argument is an array and the dummy
+! argument is allocatable or a pointer, the bounds of the dummy argument
+! are assumed from the actual argument.
+
+program test
+
+ integer :: a(3, 4, 5)
+ integer :: b(-3:3, 0:4, 2:5, 10:20)
+
+ call testit (a, rank(a), shape(a), lbound(a), ubound(a))
+ call testit (b, rank(b), shape(b), lbound(b), ubound(b))
+
+contains
+
+ subroutine testit (x, r, s, l, u) bind (c)
+ integer :: x(..)
+ integer :: r
+ integer :: s(r)
+ integer :: l(r)
+ integer :: u(r)
+
+ ! expect rank to match
+ if (rank (x) .ne. r) stop 101
+
+ ! expect shape to match
+ if (size (shape (x)) .ne. r) stop 102
+ if (any (shape (x) .ne. s)) stop 103
+
+ ! expect lbound and ubound functions to return rank-sized arrays.
+ ! for non-pointer/non-allocatable arrays, bounds are normalized
+ ! to be 1-based.
+ if (size (lbound (x)) .ne. r) stop 104
+ if (any (lbound (x) .ne. 1)) stop 105
+
+ if (size (ubound (x)) .ne. r) stop 106
+ if (any (ubound (x) .ne. u - l + 1)) stop 107
+ if (any (ubound (x) .ne. s)) stop 108
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-7.f90 b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-7.f90
new file mode 100644
index 00000000000..819ee4f4b93
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-7.f90
@@ -0,0 +1,51 @@
+! { dg-do run }
+!
+! TS 29113
+! 6.3 Argument association
+! An assumed-rank dummy argument may correspond to an actual argument of
+! any rank. [...] If the actual argument has rank greater than zero, the
+! rank and extents of the dummy argument are assumed from the actual
+! argument, including the lack of a final extent in the case of an
+! assumed-size array. If the actual argument is an array and the dummy
+! argument is allocatable or a pointer, the bounds of the dummy argument
+! are assumed from the actual argument.
+
+program test
+
+ integer, target :: a(3, 4, 5)
+ integer, target :: b(-3:3, 0:4, 2:5, 10:20)
+ integer, pointer :: aa(:,:,:)
+ integer, pointer :: bb(:,:,:,:)
+ aa => a
+ bb => b
+
+ call testit (aa, rank(a), shape(a), lbound(a), ubound(a))
+ call testit (bb, rank(b), shape(b), lbound(b), ubound(b))
+
+contains
+
+ subroutine testit (x, r, s, l, u) bind (c)
+ integer, pointer :: x(..)
+ integer :: r
+ integer :: s(r)
+ integer :: l(r)
+ integer :: u(r)
+
+ ! expect rank to match
+ if (rank (x) .ne. r) stop 101
+
+ ! expect shape to match
+ if (size (shape (x)) .ne. r) stop 102
+ if (any (shape (x) .ne. s)) stop 103
+
+ ! expect lbound and ubound functions to return rank-sized arrays.
+ ! for non-pointer/non-allocatable arrays, bounds are normalized
+ ! to be 1-based.
+ if (size (lbound (x)) .ne. r) stop 104
+ if (any (lbound (x) .ne. l)) stop 105
+
+ if (size (ubound (x)) .ne. r) stop 106
+ if (any (ubound (x) .ne. u)) stop 107
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-8.f90 b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-8.f90
new file mode 100644
index 00000000000..d94a71b4a91
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-8.f90
@@ -0,0 +1,50 @@
+! { dg-do run }
+!
+! TS 29113
+! 6.3 Argument association
+! An assumed-rank dummy argument may correspond to an actual argument of
+! any rank. [...] If the actual argument has rank greater than zero, the
+! rank and extents of the dummy argument are assumed from the actual
+! argument, including the lack of a final extent in the case of an
+! assumed-size array. If the actual argument is an array and the dummy
+! argument is allocatable or a pointer, the bounds of the dummy argument
+! are assumed from the actual argument.
+
+program test
+
+ integer, allocatable :: a(:,:,:)
+ integer, allocatable :: b(:,:,:,:)
+
+ allocate (a(3, 4, 5))
+ allocate (b(-3:3, 0:4, 2:5, 10:20))
+
+ call testit (a, rank(a), shape(a), lbound(a), ubound(a))
+ call testit (b, rank(b), shape(b), lbound(b), ubound(b))
+
+contains
+
+ subroutine testit (x, r, s, l, u) bind (c)
+ integer, allocatable :: x(..)
+ integer :: r
+ integer :: s(r)
+ integer :: l(r)
+ integer :: u(r)
+
+ ! expect rank to match
+ if (rank (x) .ne. r) stop 101
+
+ ! expect shape to match
+ if (size (shape (x)) .ne. r) stop 102
+ if (any (shape (x) .ne. s)) stop 103
+
+ ! expect lbound and ubound functions to return rank-sized arrays.
+ ! for non-pointer/non-allocatable arrays, bounds are normalized
+ ! to be 1-based.
+ if (size (lbound (x)) .ne. r) stop 104
+ if (any (lbound (x) .ne. l)) stop 105
+
+ if (size (ubound (x)) .ne. r) stop 106
+ if (any (ubound (x) .ne. u)) stop 107
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/assumed-type-dummy.f90 b/gcc/testsuite/gfortran.dg/c-interop/assumed-type-dummy.f90
new file mode 100644
index 00000000000..a14c9a59703
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/assumed-type-dummy.f90
@@ -0,0 +1,84 @@
+! PR 101319
+! { dg-do compile }
+!
+! TS 29113
+! 6.3 Argument association
+!
+! An assumed-type dummy argument shall not correspond to an actual argument
+! that is of a derived type that has type parameters, type-bound procedures,
+! or final subroutines.
+!
+! In the 2018 Fortran standard, this requirement appears as:
+!
+! 15.5.2.4 Ordinary dummy variables
+!
+! If the actual argument is of a derived type that has type parameters,
+! type-bound procedures, or final subroutines, the dummy argument shall
+! not be assumed-type.
+!
+! This file contains code that is expected to produce errors.
+
+module m
+
+ ! basic derived type
+ type :: t1
+ real*8 :: xyz (3)
+ end type
+
+ ! derived type with type parameters
+ type t2 (k, l)
+ integer, kind :: k
+ integer, len :: l
+ real(k) :: a(l)
+ end type
+
+ ! derived type with a type-bound procedure
+ type :: t3
+ integer :: xyz(3)
+ contains
+ procedure, pass :: frob => frob_t3
+ end type
+
+ ! derived type with a final subroutine
+ type :: t4
+ integer :: xyz(3)
+ contains
+ final :: final_t4
+ end type
+
+contains
+
+ ! implementation of the type-bound procedure for t3 above
+ subroutine frob_t3 (a)
+ class (t3) :: a
+ a%xyz = 0
+ end subroutine
+
+ ! implementation of the final subroutine for t4 above
+ subroutine final_t4 (a)
+ type (t4) :: a
+ a%xyz = 0
+ end subroutine
+
+ ! useless subroutine with an assumed-type dummy.
+ subroutine s1 (a)
+ type(*) :: a
+ end subroutine
+
+ ! test procedure
+ subroutine testit
+ type(t1) :: a1
+ type(t2(8,20)) :: a2
+ type(t3) :: a3
+ type(t4) :: a4
+
+ call s1 (a1) ! OK
+ call s1 (a2) ! { dg-error "assumed-type dummy" "pr101319" { xfail *-*-* } }
+ call s1 (a3) ! { dg-error "assumed-type dummy" }
+ call s1 (a4) ! { dg-error "assumed-type dummy" }
+ end subroutine
+
+end module
+
+
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c-interop.exp b/gcc/testsuite/gfortran.dg/c-interop/c-interop.exp
new file mode 100644
index 00000000000..3bc2a9f2a60
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c-interop.exp
@@ -0,0 +1,57 @@
+# Copyright (C) 2005-2021 Free Software Foundation, Inc.
+#
+# This file is part of GCC.
+#
+# GCC is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3, or (at your option)
+# any later version.
+#
+# GCC is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+# GCC testsuite that uses the `dg.exp' driver.
+
+# Load support procs.
+load_lib gfortran-dg.exp
+
+# Initialize `dg'.
+dg-init
+
+global gfortran_test_path
+global gfortran_aux_module_flags
+set gfortran_test_path $srcdir/$subdir
+set gfortran_aux_module_flags "-Werror -std=f2018"
+proc dg-compile-aux-modules { args } {
+ global gfortran_test_path
+ global gfortran_aux_module_flags
+ if { [llength $args] != 2 } {
+ error "dg-compile-aux-modules: needs one argument"
+ return
+ }
+
+ set level [info level]
+ if { [info procs dg-save-unknown] != [list] } {
+ rename dg-save-unknown dg-save-unknown-level-$level
+ }
+
+ dg-test $gfortran_test_path/[lindex $args 1] "" $gfortran_aux_module_flags
+ # cleanup-modules is intentionally not invoked here.
+
+ if { [info procs dg-save-unknown-level-$level] != [list] } {
+ rename dg-save-unknown-level-$level dg-save-unknown
+ }
+}
+
+# Main loop.
+gfortran-dg-runtest [lsort \
+ [find $srcdir/$subdir *.\[fF\]{,90,95,03,08} ] ] "" "-Werror"
+
+# All done.
+dg-finish
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90
new file mode 100644
index 00000000000..62fee2c4f50
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90
@@ -0,0 +1,83 @@
+! PR92482
+! { dg-do compile }
+!
+! TS 29113
+! C1255 (R1230) If proc-language-binding-spec is specified for a procedure,
+! each dummy argument shall be an interoperable procedure (15.3.7)
+! or a variable that is interoperable (15.3.5, 15.3.6), assumed shape,
+! assumed rank, assumed type, of assumed character length, or has the
+! ALLOCATABLE or POINTER attribute. If proc-language-binding-spec is
+! specified for a function, the function result shall be an interoperable
+! scalar variable.
+
+module m
+
+ interface
+
+ ! dummy is interoperable procedure
+ subroutine s1 (x) bind (c)
+ use ISO_C_BINDING
+ implicit none
+ interface
+ function x (a, b) bind (c)
+ use ISO_C_BINDING
+ integer(C_INT) :: a, b
+ integer(C_INT) :: x
+ end function
+ end interface
+ end subroutine
+
+ ! dummy is interoperable variable
+ subroutine s2 (x) bind (c)
+ use ISO_C_BINDING
+ implicit none
+ integer(C_INT) :: x
+ end subroutine
+
+ ! dummy is assumed-shape array variable
+ subroutine s3 (x) bind (c)
+ use ISO_C_BINDING
+ implicit none
+ integer(C_INT) :: x(:)
+ end subroutine
+
+ ! dummy is an assumed-rank array variable
+ subroutine s4 (x) bind (c)
+ use ISO_C_BINDING
+ implicit none
+ integer(C_INT) :: x(..)
+ end subroutine
+
+ ! dummy is assumed-type variable
+ subroutine s5 (x) bind (c)
+ use ISO_C_BINDING
+ implicit none
+ type(*) :: x
+ end subroutine
+
+ ! dummy is assumed length character variable
+ subroutine s6 (x) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ use ISO_C_BINDING
+ implicit none
+ character(len=*) :: x
+ end subroutine
+
+ ! dummy has allocatable or pointer attribute
+ subroutine s7 (x, y) bind (c)
+ use ISO_C_BINDING
+ implicit none
+ integer(C_INT), allocatable :: x
+ integer(C_INT), pointer :: y
+ end subroutine
+
+ ! function result shall be an interoperable scalar variable
+ function f (x) bind (c)
+ use ISO_C_BINDING
+ implicit none
+ integer(C_INT) :: x
+ integer(C_INT) :: f
+ end function
+
+ end interface
+end module
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90
new file mode 100644
index 00000000000..0e5505a0183
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90
@@ -0,0 +1,106 @@
+! { dg-do compile }
+!
+! TS 29113
+! C1255 (R1230) If proc-language-binding-spec is specified for a procedure,
+! each dummy argument shall be an interoperable procedure (15.3.7)
+! or a variable that is interoperable (15.3.5, 15.3.6), assumed shape,
+! assumed rank, assumed type, of assumed character length, or has the
+! ALLOCATABLE or POINTER attribute. If proc-language-binding-spec is
+! specified for a function, the function result shall be an interoperable
+! scalar variable.
+!
+! This file contains code that is expected to produce errors.
+
+
+module m1
+ ! type to use for examples below
+ type t
+ integer :: foo
+ real :: bar
+ end type
+end module
+
+module m2
+
+ interface
+
+ ! dummy is a procedure that is not interoperable
+ subroutine s1 (x) bind (c)
+ use ISO_C_BINDING
+ use m1
+ implicit none
+ interface
+ function x (a, b) bind (c) ! { dg-error "not C interoperable" }
+ use ISO_C_BINDING
+ use m1
+ integer(C_INT) :: a
+ class(t) :: b !
+ integer(C_INT) :: x
+ end function
+ end interface
+ end subroutine
+
+ ! dummy is of a type that is not interoperable
+ subroutine s2 (x) bind (c) ! { dg-error "not C interoperable" }
+ use ISO_C_BINDING
+ use m1
+ implicit none
+ class(t) :: x
+ end subroutine
+
+ ! dummy is an array that is not of interoperable type and not
+ ! assumed-shape or assumed-rank
+ subroutine s3 (x) bind (c) ! { dg-error "not C interoperable" }
+ use ISO_C_BINDING
+ use m1
+ implicit none
+ class(t) :: x(3, 3)
+ end subroutine
+
+ subroutine s4 (n, x) bind (c) ! { dg-error "not C interoperable" }
+ use ISO_C_BINDING
+ use m1
+ implicit none
+ integer(C_INT) :: n
+ class(t) :: x(n)
+ end subroutine
+
+ ! This fails with a bogus error even without C binding.
+ subroutine s5 (x) bind (c) ! { dg-error "not C interoperable" }
+ use ISO_C_BINDING
+ use m1
+ implicit none
+ class(t) :: x(*) ! { dg-bogus "not yet been implemented" "pr46991" }
+ ! { dg-bogus "has no IMPLICIT type" "pr46991" { target "*-*-*" } 68 }
+ end subroutine
+
+ subroutine s5a (x)
+ use ISO_C_BINDING
+ use m1
+ implicit none
+ class(t) :: x(*) ! { dg-bogus "not yet been implemented" "pr46991" }
+ ! { dg-bogus "has no IMPLICIT type" "pr46991" { target "*-*-*" } 76 }
+ end subroutine
+
+ ! function result is not a scalar
+ function f (x) bind (c) ! { dg-error "not C interoperable" }
+ use ISO_C_BINDING
+ use m1
+ implicit none
+ integer(C_INT) :: x
+ type(t) :: f
+ end function
+
+ ! function result is a type that is not interoperable
+ function g (x) bind (c) ! { dg-error "BIND\\(C\\)" }
+ use ISO_C_BINDING
+ use m1
+ implicit none
+ integer(C_INT) :: x
+ integer(C_INT), allocatable :: g
+ end function
+
+ end interface
+
+end module
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c1255a.f90 b/gcc/testsuite/gfortran.dg/c-interop/c1255a.f90
new file mode 100644
index 00000000000..470ccaca0fd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c1255a.f90
@@ -0,0 +1,40 @@
+! { dg-do compile }
+!
+! TS 29113
+! C1255a (R1230) A dummy argument of a procedure that has a
+! proc-language-binding-spec shall not have both the OPTIONAL and
+! VALUE attributes.
+!
+! This file contains code that is expected to produce errors.
+
+module m
+
+ interface
+
+ ! This one is OK.
+ subroutine s1 (x, y) bind (c)
+ use ISO_C_BINDING
+ implicit none
+ integer(C_INT) :: x
+ integer(C_INT), optional :: y
+ end subroutine
+
+ ! This one is OK too.
+ subroutine s2 (x, y) bind (c)
+ use ISO_C_BINDING
+ implicit none
+ integer(C_INT) :: x
+ integer(C_INT), value :: y
+ end subroutine
+
+ ! This one is bad.
+ subroutine s3 (x, y) bind (c) ! { dg-error "BIND\\(C\\)" }
+ use ISO_C_BINDING
+ implicit none
+ integer(C_INT) :: x
+ integer(C_INT), optional, value :: y
+ end subroutine
+
+ end interface
+
+end module
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c407a-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c407a-1.f90
new file mode 100644
index 00000000000..f239a1e8c43
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c407a-1.f90
@@ -0,0 +1,55 @@
+! { dg-do compile}
+!
+! TS 29113
+! C407a An assumed-type entity shall be a dummy variable that does not
+! have the ALLOCATABLE, CODIMENSION, INTENT(OUT), POINTER, or VALUE
+! attribute and is not an explicit-shape array.
+!
+! This test file contains tests that are expected to all pass.
+
+! Check basic usage with no attributes.
+
+module m
+ interface
+ subroutine g (a, b)
+ implicit none
+ type(*) :: a
+ integer :: b
+ end subroutine
+ end interface
+end module
+
+subroutine s0 (x)
+ use m
+ implicit none
+ type(*) :: x
+
+ call g (x, 1)
+end subroutine
+
+! Check that other attributes that can normally apply to dummy variables
+! are allowed.
+
+subroutine s1 (a, b, c, d, e, f, g, h)
+ implicit none
+ type(*), asynchronous :: a
+ type(*), contiguous :: b(:,:)
+ type(*), dimension (:) :: c
+ type(*), intent(in) :: d
+ type(*), intent(inout) :: e
+ type(*), optional :: f
+ type(*), target :: g
+ type(*), volatile :: h
+
+end subroutine
+
+! Check that non-explicit-shape arrays are allowed.
+
+subroutine s2 (a, b, c)
+ implicit none
+ type(*) :: a(:) ! assumed-shape
+ type(*) :: b(*) ! assumed-size
+ type(*) :: c(..) ! assumed-rank
+
+end subroutine
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c407a-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c407a-2.f90
new file mode 100644
index 00000000000..9d8824d48d6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c407a-2.f90
@@ -0,0 +1,88 @@
+! { dg-do compile }
+! { dg-additional-options "-fcoarray=single" }
+!
+! TS 29113
+! C407a An assumed-type entity shall be a dummy variable that does not
+! have the ALLOCATABLE, CODIMENSION, INTENT(OUT), POINTER, or VALUE
+! attribute and is not an explicit-shape array.
+!
+! This test file contains tests that are expected to issue diagnostics
+! for invalid code.
+
+! Check that diagnostics are issued when type(*) is used to declare things
+! that are not dummy variables.
+
+subroutine s0 (a)
+ implicit none
+ integer :: a
+
+ integer :: goodlocal
+ type(*) :: badlocal ! { dg-error "Assumed.type" }
+
+ integer :: goodcommon
+ type(*) :: badcommon ! { dg-error "Assumed.type" }
+ common /frob/ goodcommon, badcommon
+
+ integer :: goodstatic
+ type(*) :: badstatic ! { dg-error "Assumed.type" }
+ save goodstatic, badstatic
+
+ block
+ integer :: goodlocal2
+ type(*) :: badlocal2 ! { dg-error "Assumed.type" }
+ end block
+
+end subroutine
+
+module m
+ integer :: goodmodvar
+ type(*) :: badmodvar ! { dg-error "Assumed.type" }
+ save goodmodvar, badmodvar
+
+ type :: t
+ integer :: goodcomponent
+ type(*) :: badcomponent ! { dg-error "Assumed.type" }
+ end type
+end module
+
+! Check that diagnostics are issued when type(*) is used in combination
+! with the forbidden attributes.
+
+subroutine s1 (a) ! { dg-error "Assumed.type" }
+ implicit none
+ type(*), allocatable :: a
+end subroutine
+
+subroutine s2 (b) ! { dg-error "Assumed.type" }
+ implicit none
+ type(*), codimension[*] :: b(:,:)
+end subroutine
+
+subroutine s3 (c) ! { dg-error "Assumed.type" }
+ implicit none
+ type(*), intent(out) :: c
+end subroutine
+
+subroutine s4 (d) ! { dg-error "Assumed.type" }
+ implicit none
+ type(*), pointer :: d
+end subroutine
+
+subroutine s5 (e) ! { dg-error "Assumed.type" }
+ implicit none
+ type(*), value :: e
+end subroutine
+
+! Check that diagnostics are issued when type(*) is used to declare
+! a dummy variable that is an explicit-shape array.
+
+subroutine s6 (n, f) ! { dg-error "Assumed.type" }
+ implicit none
+ integer n
+ type(*) :: f(n,n)
+end subroutine
+
+subroutine s7 (g) ! { dg-error "Assumed.type" }
+ implicit none
+ type(*) :: g(10)
+end subroutine
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c407b-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c407b-1.f90
new file mode 100644
index 00000000000..c9fc2b99647
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c407b-1.f90
@@ -0,0 +1,107 @@
+! { dg-do compile}
+!
+! TS 29113
+! C407b An assumed-type variable name shall not appear in a designator
+! or expression except as an actual argument corresponding to a dummy
+! argument that is assumed-type, or as the first argument to any of
+! the intrinsic and intrinsic module functions IS_CONTIGUOUS, LBOUND,
+! PRESENT, RANK, SHAPE, SIZE, UBOUND, and C_LOC.
+!
+! This test file contains tests that are expected to all pass.
+
+! Check that passing an assumed-type variable as an actual argument
+! corresponding to an assumed-type dummy works.
+
+module m
+ interface
+ subroutine g (a, b)
+ implicit none
+ type(*) :: a
+ integer :: b
+ end subroutine
+ end interface
+end module
+
+subroutine s0 (x)
+ use m
+ implicit none
+ type(*) :: x
+
+ call g (x, 1)
+end subroutine
+
+! Check that calls to the permitted intrinsic functions work.
+
+function test_is_contiguous (a)
+ implicit none
+ type(*) :: a(*)
+ logical :: test_is_contiguous
+
+ test_is_contiguous = is_contiguous (a)
+end function
+
+function test_lbound (a)
+ implicit none
+ type(*) :: a(:)
+ integer :: test_lbound
+
+ test_lbound = lbound (a, 1)
+end function
+
+function test_present (a)
+ implicit none
+ type(*), optional :: a(*)
+ logical :: test_present
+
+ test_present = present (a)
+end function
+
+function test_rank (a)
+ implicit none
+ type(*) :: a(*)
+ integer :: test_rank
+
+ test_rank = rank (a)
+end function
+
+function test_shape (a)
+ implicit none
+ type(*) :: a(:) ! assumed-shape array so shape intrinsic works
+ integer :: test_shape
+
+ integer :: temp, i
+ integer, dimension (rank (a)) :: ashape
+
+ temp = 1
+ ashape = shape (a)
+ do i = 1, rank (a)
+ temp = temp * ashape (i)
+ end do
+ test_shape = temp
+end function
+
+function test_size (a)
+ implicit none
+ type(*) :: a(:)
+ integer :: test_size
+
+ test_size = size (a)
+end function
+
+function test_ubound (a)
+ implicit none
+ type(*) :: a(:)
+ integer :: test_ubound
+
+ test_ubound = ubound (a, 1)
+end function
+
+function test_c_loc (a)
+ use iso_c_binding
+ implicit none
+ type(*), target :: a(*)
+ type(c_ptr) :: test_c_loc
+
+ test_c_loc = c_loc (a)
+end function
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90
new file mode 100644
index 00000000000..3d3cd635279
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90
@@ -0,0 +1,150 @@
+! PR 101337
+! { dg-do compile}
+!
+! TS 29113
+! C407b An assumed-type variable name shall not appear in a designator
+! or expression except as an actual argument corresponding to a dummy
+! argument that is assumed-type, or as the first argument to any of
+! the intrinsic and intrinsic module functions IS_CONTIGUOUS, LBOUND,
+! PRESENT, RANK, SHAPE, SIZE, UBOUND, and C_LOC.
+!
+! This file contains tests that are expected to give diagnostics.
+
+! Check that passing an assumed-type variable as an actual argument
+! corresponding to a non-assumed-type dummy gives a diagnostic.
+
+module m
+ interface
+ subroutine f (a, b)
+ implicit none
+ integer :: a
+ integer :: b
+ end subroutine
+ subroutine g (a, b)
+ implicit none
+ type(*) :: a
+ integer :: b
+ end subroutine
+ subroutine h (a, b)
+ implicit none
+ type(*) :: a(*)
+ integer :: b
+ end subroutine
+ end interface
+end module
+
+subroutine s0 (x)
+ use m
+ implicit none
+ type(*) :: x
+
+ call g (x, 1)
+ call f (x, 1) ! { dg-error "Type mismatch" }
+ call h (x, 1) ! { dg-error "Rank mismatch" }
+end subroutine
+
+! Check that you can't use an assumed-type array variable in an array
+! element or section designator.
+
+subroutine s1 (x, y)
+ use m
+ implicit none
+ integer :: x(*)
+ type(*) :: y(*)
+
+ call f (x(1), 1)
+ call g (y(1), 1) ! { dg-error "Assumed.type" }
+ call h (y, 1) ! ok
+ call h (y(1:3:1), 1) ! { dg-error "Assumed.type" }
+end subroutine
+
+! Check that you can't use an assumed-type array variable in other
+! expressions. This is clearly not exhaustive since few operations
+! are even plausible from a type perspective.
+
+subroutine s2 (x, y)
+ implicit none
+ type(*) :: x, y
+ integer :: i
+
+ ! select type
+ select type (x) ! { dg-error "Assumed.type|Selector shall be polymorphic" }
+ type is (integer)
+ i = 0
+ type is (real)
+ i = 1
+ class default
+ i = -1
+ end select
+
+ ! relational operations
+ if (x & ! { dg-error "Assumed.type" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ .eq. y) then ! { dg-error "Assumed.type" }
+ return
+ end if
+ if (.not. (x & ! { dg-error "Assumed.type" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ .ne. y)) then ! { dg-error "Assumed.type" }
+ return
+ end if
+ if (.not. x) then ! { dg-error "Assumed.type" }
+ return
+ end if
+
+ ! assignment
+ x & ! { dg-error "Assumed.type" }
+ = y ! { dg-error "Assumed.type" }
+ i = x ! { dg-error "Assumed.type" }
+ y = i ! { dg-error "Assumed.type" }
+
+ ! arithmetic
+ i = x + 1 ! { dg-error "Assumed.type" }
+ i = -y ! { dg-error "Assumed.type" }
+ i = (x & ! { dg-error "Assumed.type" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ + y) ! { dg-error "Assumed.type" }
+
+ ! computed go to
+ goto (10, 20, 30), x ! { dg-error "Assumed.type|must be a scalar integer" }
+10 continue
+20 continue
+30 continue
+
+ ! do loops
+ do i = 1, x ! { dg-error "Assumed.type" }
+ continue
+ end do
+ do x = 1, i ! { dg-error "Assumed.type" }
+ continue
+ end do
+
+end subroutine
+
+! Check that calls to disallowed intrinsic functions produce a diagnostic.
+! Again, this isn't exhaustive, there are just too many intrinsics and
+! hardly any of them are plausible.
+
+subroutine s3 (x, y)
+ implicit none
+ type(*) :: x, y
+ integer :: i
+
+ i = bit_size (x) ! { dg-error "Assumed.type" }
+ i = exponent (x) ! { dg-error "Assumed.type" }
+
+ if (extends_type_of (x, & ! { dg-error "Assumed.type" }
+ y)) then ! { dg-error "Assumed.type" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ return
+ end if
+
+ if (same_type_as (x, & ! { dg-error "Assumed.type" }
+ y)) then ! { dg-error "Assumed.type" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ return
+ end if
+
+ i = storage_size (x) ! { dg-error "Assumed.type" }
+
+ i = iand (x, & ! { dg-error "Assumed.type" }
+ y) ! { dg-error "Assumed.type" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+
+ i = kind (x) ! { dg-error "Assumed.type" }
+
+end subroutine
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90
new file mode 100644
index 00000000000..e4da66adade
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90
@@ -0,0 +1,63 @@
+! PR101333
+! { dg-do compile}
+!
+! TS 29113
+! C407c An assumed-type actual argument that corresponds to an
+! assumed-rank dummy argument shall be assumed-shape or assumed-rank.
+!
+! This constraint is renumbered C711 in the 2018 Fortran standard.
+
+module m
+ interface
+ subroutine g (a, b)
+ implicit none
+ type(*) :: a(..)
+ integer :: b
+ end subroutine
+ end interface
+end module
+
+! Check that assumed-shape works.
+
+subroutine s0 (x)
+ use m
+ implicit none
+ type(*) :: x(:)
+
+ call g (x, 1)
+end subroutine
+
+! Check that assumed-rank works.
+
+subroutine s1 (x)
+ use m
+ implicit none
+ type(*) :: x(..)
+
+ call g (x, 1)
+end subroutine
+
+! Check that assumed-size gives an error.
+
+subroutine s2 (x)
+ use m
+ implicit none
+ type(*) :: x(*)
+
+ call g (x, 1) ! { dg-error "Assumed.type" "pr101333" { xfail *-*-* } }
+end subroutine
+
+! Check that a scalar gives an error.
+subroutine s3 (x)
+ use m
+ implicit none
+ type(*) :: x
+
+ call g (x, 1) ! { dg-error "Assumed.type" "pr101333" { xfail *-*-* } }
+end subroutine
+
+! Explicit-shape assumed-type actual arguments are forbidden implicitly
+! by c407a (C709 in the 2018 standard). They're not allowed as dummy
+! arguments, and assumed-type entities can only be declared as dummy
+! arguments, so there is no other way to construct one to pass as an
+! actual argument.
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c516.f90 b/gcc/testsuite/gfortran.dg/c-interop/c516.f90
new file mode 100644
index 00000000000..208eb846ea5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c516.f90
@@ -0,0 +1,67 @@
+! PR 101320
+! { dg-do compile }
+!
+! TS 29113
+! C516 The ALLOCATABLE or POINTER attribute shall not be specified for
+! a default-initialized dummy argument of a procedure that has a
+! proc-language-binding-spec.
+!
+! This file contains code that is expected to produce errors.
+
+module m1
+
+ type, bind(c) :: t1
+ integer :: a
+ integer :: b
+ end type
+
+
+ type, bind(c) :: t2
+ integer :: a = 0
+ integer :: b = -1
+ end type
+
+end module
+
+module m2
+
+ interface
+
+ ! good, no default initialization, no pointer/allocatable attribute
+ subroutine s1a (x) bind (c)
+ use m1
+ type(t1), optional :: x
+ end subroutine
+
+ ! good, no default initialization
+ subroutine s1b (x) bind (c)
+ use m1
+ type(t1), allocatable, optional :: x
+ end subroutine
+
+ ! good, no default initialization
+ subroutine s1c (x) bind (c)
+ use m1
+ type(t1), pointer, optional :: x
+ end subroutine
+
+ ! good, default initialization but no pointer/allocatable attribute
+ subroutine s2a (x) bind (c)
+ use m1
+ type(t2), optional :: x
+ end subroutine
+
+ ! bad, default initialization + allocatable
+ subroutine s2b (x) bind (c) ! { dg-error "BIND\\(C\\)" "pr101320" { xfail *-*-* } }
+ use m1
+ type(t2), allocatable, optional :: x
+ end subroutine
+
+ ! bad, default initialization + pointer
+ subroutine s2c (x) bind (c) ! { dg-error "BIND\\(C\\)" "pr101320" { xfail *-*-* } }
+ use m1
+ type(t2), pointer, optional :: x
+ end subroutine
+
+ end interface
+end module
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c524a.f90 b/gcc/testsuite/gfortran.dg/c-interop/c524a.f90
new file mode 100644
index 00000000000..34abb72b325
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c524a.f90
@@ -0,0 +1,30 @@
+! { dg-do compile }
+! { dg-additional-options "-fcoarray=single" }
+!
+! TS 29113
+! C524a A coarray shall not be a dummy argument of a procedure that has
+! a proc-language-binding-spec.
+!
+! This file contains code that is expected to produce errors.
+
+module m
+
+ interface
+
+ ! No C binding, this should be OK.
+ subroutine s1 (x)
+ use ISO_C_BINDING
+ implicit none
+ integer(C_INT), codimension[*] :: x(:,:)
+ end subroutine
+
+ ! This one is bad.
+ subroutine s2 (x) bind (c) ! { dg-error "BIND\\(C\\)" }
+ use ISO_C_BINDING
+ implicit none
+ integer(C_INT), codimension[*] :: x(:,:)
+ end subroutine
+
+ end interface
+end module
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535a-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535a-1.f90
new file mode 100644
index 00000000000..5550cf24005
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535a-1.f90
@@ -0,0 +1,65 @@
+! { dg-do compile}
+!
+! TS 29113
+! C535a An assumed-rank entity shall be a dummy variable that does not
+! have the CODIMENSION or VALUE attribute.
+! An assumed-rank object may have the CONTIGUOUS attribute.
+!
+! This test file contains tests that are expected to all pass.
+
+! Check basic usage with no attributes.
+
+module m
+ type :: t
+ integer :: i
+ real :: f
+ end type
+end module
+
+subroutine s0 (a, b, c, d)
+ use m
+ implicit none
+ integer :: a(..)
+ real :: b(..)
+ type(t) :: c(..)
+ type(*) :: d(..)
+end subroutine
+
+! Likewise with dimension attribute.
+
+subroutine s1 (a, b, c, d)
+ use m
+ implicit none
+ integer, dimension(..) :: a
+ real, dimension(..) :: b
+ type(t), dimension(..) :: c
+ type(*), dimension(..) :: d
+end subroutine
+
+! Likewise with dimension statement.
+
+subroutine s2 (a, b, c, d)
+ use m
+ implicit none
+ integer :: a
+ real :: b
+ type(t) :: c
+ type(*) :: d
+ dimension a(..), b(..), c(..), d(..)
+end subroutine
+
+! Test that various other attributes are accepted.
+
+subroutine s3 (a, b, c, d, e, f, g, h, i, j)
+ implicit none
+ integer, allocatable :: a(..)
+ integer, asynchronous :: b(..)
+ integer, contiguous :: c(..)
+ integer, intent(in) :: d(..)
+ integer, intent(out) :: e(..)
+ integer, intent(inout) :: f(..)
+ integer, optional :: g(..)
+ integer, pointer :: h(..)
+ integer, target :: i(..)
+ integer, volatile :: j(..)
+end subroutine
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535a-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535a-2.f90
new file mode 100644
index 00000000000..026be4a5525
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535a-2.f90
@@ -0,0 +1,78 @@
+! { dg-do compile}
+! { dg-additional-options "-fcoarray=single" }
+!
+! TS 29113
+! C535a An assumed-rank entity shall be a dummy variable that does not
+! have the CODIMENSION or VALUE attribute.
+! An assumed-rank object may have the CONTIGUOUS attribute.
+!
+
+! This test file contains tests that are expected to issue diagnostics
+! for invalid code.
+
+! Check that diagnostics are issued when dimension(..) is used to declare
+! things that are not dummy variables.
+
+subroutine s0 (a)
+ implicit none
+ integer :: a
+
+ integer :: goodlocal
+ integer :: badlocal1(..) ! { dg-error "Assumed.rank" }
+ integer, dimension(..) :: badlocal2 ! { dg-error "Assumed.rank" }
+ integer :: badlocal3 ! { dg-error "Assumed.rank" }
+ dimension badlocal3(..)
+
+ integer :: goodcommon
+ integer :: badcommon1(..) ! { dg-error "Assumed.rank" }
+ integer, dimension(..) :: badcommon2 ! { dg-error "Assumed.rank" }
+ integer :: badcommon3 ! { dg-error "Assumed.rank" }
+ dimension badcommon3(..)
+ common /frob/ goodcommon, badcommon1, badcommon2, badcommon3
+
+ integer :: goodstatic
+ integer :: badstatic1(..) ! { dg-error "Assumed.rank" }
+ integer, dimension(..) :: badstatic2 ! { dg-error "Assumed.rank" }
+ integer :: badstatic3 ! { dg-error "Assumed.rank" }
+ dimension badstatic3(..)
+ save goodstatic, badstatic1, badstatic2, badstatic3
+
+ block
+ integer :: goodblocklocal
+ integer :: badblocklocal1(..) ! { dg-error "Assumed.rank" }
+ integer, dimension(..) :: badblocklocal2 ! { dg-error "Assumed.rank" }
+ integer :: badblocklocal3 ! { dg-error "Assumed.rank" }
+ dimension badblocklocal3(..)
+ end block
+
+end subroutine
+
+module m
+ integer :: goodmodvar
+ integer :: badmodvar1(..) ! { dg-error "Assumed.rank" }
+ integer, dimension(..) :: badmodvar2 ! { dg-error "Assumed.rank" }
+ integer :: badmodvar3 ! { dg-error "Assumed.rank" }
+ dimension badmodvar3(..)
+
+ save goodmodvar, badmodvar1, badmodvar2, badmodvar3
+
+ type :: t
+ integer :: goodcomponent
+ integer :: badcomponent1(..) ! { dg-error "must have an explicit shape" }
+ integer, dimension(..) :: badcomponent2 ! { dg-error "must have an explicit shape" }
+ end type
+end module
+
+! Check that diagnostics are issued when dimension(..) is used in combination
+! with the forbidden attributes.
+
+subroutine s2 (b) ! { dg-error "has no IMPLICIT type" }
+ implicit none
+ integer, codimension[*] :: b(..) ! { dg-error "assumed-rank array" }
+end subroutine
+
+subroutine s5 (e) ! { dg-error "has no IMPLICIT type" }
+ implicit none
+ integer, value :: e(..) ! { dg-error "VALUE attribute conflicts with DIMENSION" }
+end subroutine
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535b-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535b-1.f90
new file mode 100644
index 00000000000..3de77b00106
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535b-1.f90
@@ -0,0 +1,333 @@
+! { dg-do compile}
+! { dg-additional-options "-fcoarray=single" }
+!
+! TS 29113
+! C535b An assumed-rank variable name shall not appear in a designator
+! or expression except as an actual argument corresponding to a dummy
+! argument that is assumed-rank, the argument of the C_LOC function
+! in the ISO_C_BINDING intrinsic module, or the first argument in a
+! reference to an intrinsic inquiry function.
+!
+! This has been renamed C838 in the Fortran 2018 standard, with C_SIZEOF
+! and SELECT_RANK additionally added.
+!
+! This test file contains tests that are expected to all pass.
+
+! Check that passing an assumed-rank variable as an actual argument
+! corresponding to an assumed-rank dummy works.
+
+module m
+ interface
+ subroutine g (a, b)
+ implicit none
+ real :: a(..)
+ integer :: b
+ end subroutine
+ end interface
+end module
+
+subroutine s0 (x)
+ use m
+ implicit none
+ real :: x(..)
+
+ call g (x, 1)
+end subroutine
+
+! Check that calls to the permitted intrinsic functions work.
+
+function test_c_loc (a)
+ use iso_c_binding
+ implicit none
+ integer, target :: a(..)
+ type(c_ptr) :: test_c_loc
+
+ test_c_loc = c_loc (a)
+end function
+
+function test_allocated (a)
+ implicit none
+ integer, allocatable :: a(..)
+ logical :: test_allocated
+
+ test_allocated = allocated (a)
+end function
+
+! 2-argument forms of the associated intrinsic are tested in c535b-3.f90.
+function test_associated (a)
+ implicit none
+ integer, pointer :: a(..)
+ logical :: test_associated
+
+ test_associated = associated (a)
+end function
+
+function test_bit_size (a)
+ implicit none
+ integer :: a(..)
+ integer :: test_bit_size
+
+ test_bit_size = bit_size (a)
+end function
+
+function test_digits (a)
+ implicit none
+ integer :: a(..)
+ integer :: test_digits
+
+ test_digits = digits (a)
+end function
+
+function test_epsilon (a)
+ implicit none
+ real :: a(..)
+ real :: test_epsilon
+
+ test_epsilon = epsilon (a)
+end function
+
+function test_huge (a)
+ implicit none
+ integer :: a(..)
+ integer :: test_huge
+
+ test_huge = huge (a)
+end function
+
+function test_is_contiguous (a)
+ implicit none
+ integer :: a(..)
+ logical :: test_is_contiguous
+
+ test_is_contiguous = is_contiguous (a)
+end function
+
+function test_kind (a)
+ implicit none
+ integer :: a(..)
+ integer :: test_kind
+
+ test_kind = kind (a)
+end function
+
+function test_lbound (a)
+ implicit none
+ integer :: a(..)
+ integer :: test_lbound
+
+ test_lbound = lbound (a, 1)
+end function
+
+function test_len1 (a)
+ implicit none
+ character(len=5) :: a(..)
+ integer :: test_len1
+
+ test_len1 = len (a)
+end function
+
+function test_len2 (a)
+ implicit none
+ character(len=*) :: a(..)
+ integer :: test_len2
+
+ test_len2 = len (a)
+end function
+
+function test_len3 (a)
+ implicit none
+ character(len=5), pointer :: a(..)
+ integer :: test_len3
+
+ test_len3 = len (a)
+end function
+
+function test_len4 (a)
+ implicit none
+ character(len=*), pointer :: a(..)
+ integer :: test_len4
+
+ test_len4 = len (a)
+end function
+
+function test_len5 (a)
+ implicit none
+ character(len=:), pointer :: a(..)
+ integer :: test_len5
+
+ test_len5 = len (a)
+end function
+
+function test_len6 (a)
+ implicit none
+ character(len=5), allocatable :: a(..)
+ integer :: test_len6
+
+ test_len6 = len (a)
+end function
+
+function test_len7 (a)
+ implicit none
+ character(len=*), allocatable :: a(..)
+ integer :: test_len7
+
+ test_len7 = len (a)
+end function
+
+function test_len8 (a)
+ implicit none
+ character(len=:), allocatable :: a(..)
+ integer :: test_len8
+
+ test_len8 = len (a)
+end function
+
+function test_maxexponent (a)
+ implicit none
+ real :: a(..)
+ integer :: test_maxexponent
+
+ test_maxexponent = maxexponent (a)
+end function
+
+function test_minexponent (a)
+ implicit none
+ real :: a(..)
+ integer :: test_minexponent
+
+ test_minexponent = minexponent (a)
+end function
+
+function test_new_line (a)
+ implicit none
+ character :: a(..)
+ character :: test_new_line
+
+ test_new_line = new_line (a)
+end function
+
+function test_precision (a)
+ implicit none
+ real :: a(..)
+ integer :: test_precision
+
+ test_precision = precision (a)
+end function
+
+function test_present (a, b, c)
+ implicit none
+ integer :: a, b
+ integer, optional :: c(..)
+ integer :: test_present
+
+ if (present (c)) then
+ test_present = a
+ else
+ test_present = b
+ end if
+end function
+
+function test_radix (a)
+ implicit none
+ real :: a(..)
+ integer :: test_radix
+
+ test_radix = radix (a)
+end function
+
+function test_range (a)
+ implicit none
+ real :: a(..)
+ integer :: test_range
+
+ test_range = range (a)
+end function
+
+function test_rank (a)
+ implicit none
+ integer :: a(..)
+ integer :: test_rank
+
+ test_rank = rank (a)
+end function
+
+function test_shape (a)
+ implicit none
+ integer :: a(..)
+ logical :: test_shape
+
+ test_shape = (rank (a) .eq. size (shape (a)))
+end function
+
+function test_size (a)
+ implicit none
+ integer :: a(..)
+ logical :: test_size
+
+ test_size = (size (a) .eq. product (shape (a)))
+end function
+
+function test_storage_size (a)
+ implicit none
+ integer :: a(..)
+ integer :: test_storage_size
+
+ test_storage_size = storage_size (a)
+end function
+
+function test_tiny (a)
+ implicit none
+ real :: a(..)
+ real :: test_tiny
+
+ test_tiny = tiny (a)
+end function
+
+function test_ubound (a)
+ implicit none
+ integer :: a(..)
+ integer :: test_ubound
+
+ test_ubound = ubound (a, 1)
+end function
+
+! Note: there are no tests for these inquiry functions that can't
+! take an assumed-rank array argument for other reasons:
+!
+! coshape, lcobound, ucobound: requires CODIMENSION attribute, which is
+! not permitted on an assumed-rank variable.
+!
+! extends_type_of, same_type_as: require a class argument.
+
+
+! F2018 additionally permits the first arg to C_SIZEOF to be
+! assumed-rank (C838).
+
+function test_c_sizeof (a)
+ use iso_c_binding
+ implicit none
+ integer :: a(..)
+ integer :: test_c_sizeof
+
+ test_c_sizeof = c_sizeof (a)
+end function
+
+! F2018 additionally permits an assumed-rank array as the selector
+! in a SELECT RANK construct (C838).
+
+function test_select_rank (a)
+ implicit none
+ integer :: a(..)
+ integer :: test_select_rank
+
+ select rank (a)
+ rank (0)
+ test_select_rank = 0
+ rank (1)
+ test_select_rank = 1
+ rank (2)
+ test_select_rank = 2
+ rank default
+ test_select_rank = -1
+ end select
+end function
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90
new file mode 100644
index 00000000000..7bff14fe9ef
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90
@@ -0,0 +1,387 @@
+! PR 101334
+! PR 101337
+! { dg-do compile}
+! { dg-additional-options "-fcoarray=single" }
+!
+! TS 29113
+! C535b An assumed-rank variable name shall not appear in a designator
+! or expression except as an actual argument corresponding to a dummy
+! argument that is assumed-rank, the argument of the C_LOC function
+! in the ISO_C_BINDING intrinsic module, or the first argument in a
+! reference to an intrinsic inquiry function.
+!
+! This has been renamed C838 in the Fortran 2018 standard, with C_SIZEOF
+! and SELECT_RANK additionally added.
+!
+! This test file contains tests that are expected to issue diagnostics
+! for invalid code.
+
+! Check that passing an assumed-rank variable as an actual argument
+! corresponding to a non-assumed-rank dummy gives a diagnostic.
+
+module m
+ interface
+ subroutine f (a, b)
+ implicit none
+ integer :: a
+ integer :: b
+ end subroutine
+ subroutine g (a, b)
+ implicit none
+ integer :: a(..)
+ integer :: b(..)
+ end subroutine
+ subroutine h (a, b)
+ implicit none
+ integer :: a(*)
+ integer :: b(*)
+ end subroutine
+ subroutine i (a, b)
+ implicit none
+ integer :: a(:)
+ integer :: b(:)
+ end subroutine
+ subroutine j (a, b)
+ implicit none
+ integer :: a(3,3)
+ integer :: b(3,3)
+ end subroutine
+ end interface
+end module
+
+subroutine test_calls (x, y)
+ use m
+ implicit none
+ integer :: x(..), y(..)
+
+ ! Make sure each invalid argument produces a diagnostic.
+ ! scalar dummies
+ call f (x, & ! { dg-error "(A|a)ssumed.rank" }
+ y) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ ! assumed-rank dummies
+ call g (x, y) ! OK
+ ! assumed-size dummies
+ call h (x, & ! { dg-error "(A|a)ssumed.rank" "pr101334" { xfail *-*-* } }
+ y) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ ! assumed-shape dummies
+ call i (x, & ! { dg-error "(A|a)ssumed.rank" }
+ y) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ ! fixed-size array dummies
+ call j (x, & ! { dg-error "(A|a)ssumed.rank" "pr101334" { xfail *-*-* } }
+ y) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ ! { dg-bogus "Actual argument contains too few elements" "pr101334" { xfail *-*-* } .-2 }
+end subroutine
+
+! Check that you can't use an assumed-rank array variable in an array
+! element or section designator.
+
+subroutine test_designators (x)
+ use m
+ implicit none
+ integer :: x(..)
+
+ call f (x(1), 1) ! { dg-error "(A|a)ssumed.rank" }
+ call g (x(1:3:1), & ! { dg-error "(A|a)ssumed.rank" }
+ x) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+end subroutine
+
+! Check that you can't use an assumed-rank array variable in elemental
+! expressions. Make sure binary operators produce the error for either or
+! both operands.
+
+subroutine test_expressions (a, b, c, l, m, n, x, y, z, p, q, r, s, i, j)
+ implicit none
+ integer :: a(..), b(..), c(..)
+ logical :: l(..), m(..), n(..)
+ integer :: x(s), y(s), z(s)
+ logical :: p(s), q(s), r(s)
+ integer :: s
+ integer :: i
+ logical :: j
+
+ ! Assignment
+
+ z = x ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = a ! { dg-error "(A|a)ssumed.rank" }
+ z = i ! OK
+ c = i ! { dg-error "(A|a)ssumed.rank" }
+
+ r = p ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = l ! { dg-error "(A|a)ssumed.rank" }
+ r = j ! OK
+ n = j ! { dg-error "(A|a)ssumed.rank" }
+
+ ! Arithmetic
+
+ z = -x ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = -a ! { dg-error "(A|a)ssumed.rank" }
+ z = -i ! OK
+ c = -i ! { dg-error "(A|a)ssumed.rank" }
+
+ z = x + y ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = a & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ + b ! { dg-error "(A|a)ssumed.rank" }
+ z = x + i ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = a + i ! { dg-error "(A|a)ssumed.rank" }
+ z = i + y ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = i + b ! { dg-error "(A|a)ssumed.rank" }
+
+ z = x - y ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = a & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ - b ! { dg-error "(A|a)ssumed.rank" }
+ z = x - i ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = a - i ! { dg-error "(A|a)ssumed.rank" }
+ z = i - y ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = i - b ! { dg-error "(A|a)ssumed.rank" }
+
+ z = x * y ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = a & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ * b ! { dg-error "(A|a)ssumed.rank" }
+ z = x * i ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = a * i ! { dg-error "(A|a)ssumed.rank" }
+ z = i * y ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = i * b ! { dg-error "(A|a)ssumed.rank" }
+
+ z = x / y ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = a & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ / b ! { dg-error "(A|a)ssumed.rank" }
+ z = x / i ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = a / i ! { dg-error "(A|a)ssumed.rank" }
+ z = i / y ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = i / b ! { dg-error "(A|a)ssumed.rank" }
+
+ z = x ** y ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = a & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ ** b ! { dg-error "(A|a)ssumed.rank" }
+ z = x ** i ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = a ** i ! { dg-error "(A|a)ssumed.rank" }
+ z = i ** y ! OK
+ c & ! { dg-error "(A|a)ssumed.rank" }
+ = i ** b ! { dg-error "(A|a)ssumed.rank" }
+
+ ! Comparisons
+
+ r = x .eq. y ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = a & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ .eq. b ! { dg-error "(A|a)ssumed.rank" }
+ r = x .eq. i ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = a .eq. i ! { dg-error "(A|a)ssumed.rank" }
+ r = i .eq. y ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = i .eq. b ! { dg-error "(A|a)ssumed.rank" }
+
+ r = x .ne. y ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = a & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ .ne. b ! { dg-error "(A|a)ssumed.rank" }
+ r = x .ne. i ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = a .ne. i ! { dg-error "(A|a)ssumed.rank" }
+ r = i .ne. y ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = i .ne. b ! { dg-error "(A|a)ssumed.rank" }
+
+ r = x .lt. y ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = a & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ .lt. b ! { dg-error "(A|a)ssumed.rank" }
+ r = x .lt. i ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = a .lt. i ! { dg-error "(A|a)ssumed.rank" }
+ r = i .lt. y ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = i .lt. b ! { dg-error "(A|a)ssumed.rank" }
+
+ r = x .le. y ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = a & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ .le. b ! { dg-error "(A|a)ssumed.rank" }
+ r = x .le. i ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = a .le. i ! { dg-error "(A|a)ssumed.rank" }
+ r = i .le. y ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = i .le. b ! { dg-error "(A|a)ssumed.rank" }
+
+ r = x .gt. y ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = a & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ .gt. b ! { dg-error "(A|a)ssumed.rank" }
+ r = x .gt. i ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = a .gt. i ! { dg-error "(A|a)ssumed.rank" }
+ r = i .gt. y ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = i .gt. b ! { dg-error "(A|a)ssumed.rank" }
+
+ r = x .ge. y ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = a & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ .ge. b ! { dg-error "(A|a)ssumed.rank" }
+ r = x .ge. i ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = a .ge. i ! { dg-error "(A|a)ssumed.rank" }
+ r = i .ge. y ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = i .ge. b ! { dg-error "(A|a)ssumed.rank" }
+
+ ! Logical operators
+
+ r = .not. p ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = .not. l ! { dg-error "(A|a)ssumed.rank" }
+ r = .not. j ! OK
+ n = .not. j ! { dg-error "(A|a)ssumed.rank" }
+
+ r = p .and. q ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = l & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ .and. m ! { dg-error "(A|a)ssumed.rank" }
+ r = p .and. j ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = l .and. j ! { dg-error "(A|a)ssumed.rank" }
+ r = j .and. q ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = j .and. m ! { dg-error "(A|a)ssumed.rank" }
+
+ r = p .or. q ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = l & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ .or. m ! { dg-error "(A|a)ssumed.rank" }
+ r = p .or. j ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = l .or. j ! { dg-error "(A|a)ssumed.rank" }
+ r = j .or. q ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = j .or. m ! { dg-error "(A|a)ssumed.rank" }
+
+ r = p .eqv. q ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = l & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ .eqv. m ! { dg-error "(A|a)ssumed.rank" }
+ r = p .eqv. j ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = l .eqv. j ! { dg-error "(A|a)ssumed.rank" }
+ r = j .eqv. q ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = j .eqv. m ! { dg-error "(A|a)ssumed.rank" }
+
+ r = p .neqv. q ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = l & ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ .neqv. m ! { dg-error "(A|a)ssumed.rank" }
+ r = p .neqv. j ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = l .neqv. j ! { dg-error "(A|a)ssumed.rank" }
+ r = j .neqv. q ! OK
+ n & ! { dg-error "(A|a)ssumed.rank" }
+ = j .neqv. m ! { dg-error "(A|a)ssumed.rank" }
+
+end subroutine
+
+! Check that calls to disallowed intrinsic functions produce a diagnostic.
+! There are 100+ "elemental" intrinsics defined in the standard, and
+! 25+ "transformational" intrinsics that accept array operands, and that
+! doesn't include intrinsics in the standard modules. To keep the length of
+! this test to something sane, check only a handful of these functions on
+! the theory that related functions are probably implemented similarly and
+! probably share the same argument-processing code.
+
+subroutine test_intrinsics (i1, i2, r1, r2, c1, c2, l1, l2, s1, s2)
+ implicit none
+ integer :: i1(..), i2(..)
+ real :: r1(..), r2(..)
+ complex :: c1(..), c2(..)
+ logical :: l1(..), l2(..)
+ character :: s1(..), s2(..)
+
+ integer :: i
+ real :: r
+ logical :: l
+
+ ! trig, hyperbolic, other math functions
+ r1 & ! { dg-error "(A|a)ssumed.rank" }
+ = atan2 (r1, & ! { dg-error "(A|a)ssumed.rank" }
+ r2) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ r1 & ! { dg-error "(A|a)ssumed.rank" }
+ = atan (r2) ! { dg-error "(A|a)ssumed.rank" }
+ c1 & ! { dg-error "(A|a)ssumed.rank" }
+ = atan (c2) ! { dg-error "(A|a)ssumed.rank" }
+ r1 & ! { dg-error "(A|a)ssumed.rank" }
+ = cos (r2) ! { dg-error "(A|a)ssumed.rank" }
+ r1 & ! { dg-error "(A|a)ssumed.rank" }
+ = exp (r2) ! { dg-error "(A|a)ssumed.rank" }
+ r1 & ! { dg-error "(A|a)ssumed.rank" }
+ = sinh (r2) ! { dg-error "(A|a)ssumed.rank" }
+
+ ! bit operations
+ l1 & ! { dg-error "(A|a)ssumed.rank" }
+ = blt (i1, & ! { dg-error "(A|a)ssumed.rank" }
+ i2) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ l1 & ! { dg-error "(A|a)ssumed.rank" }
+ = btest (i1, 0) ! { dg-error "(A|a)ssumed.rank" }
+ i1 & ! { dg-error "(A|a)ssumed.rank" }
+ = not (i2) ! { dg-error "(A|a)ssumed.rank" }
+ i1 & ! { dg-error "(A|a)ssumed.rank" }
+ = popcnt (i2) ! { dg-error "(A|a)ssumed.rank" }
+
+ ! type conversions
+ s1 & ! { dg-error "(A|a)ssumed.rank" }
+ = char (i1) ! { dg-error "(A|a)ssumed.rank" }
+ c1 & ! { dg-error "(A|a)ssumed.rank" }
+ = cmplx (r1, & ! { dg-error "(A|a)ssumed.rank" }
+ r2) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ i1 & ! { dg-error "(A|a)ssumed.rank" }
+ = floor (r1) ! { dg-error "(A|a)ssumed.rank" }
+ r1 & ! { dg-error "(A|a)ssumed.rank" }
+ = real (c1) ! { dg-error "(A|a)ssumed.rank" }
+
+ ! reductions
+ l = any (l2) ! { dg-error "(A|a)ssumed.rank" }
+ r = dot_product (r1, & ! { dg-error "(A|a)ssumed.rank" }
+ r2) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ i = iall (i2, & ! { dg-error "(A|a)ssumed.rank" }
+ l2) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+
+ ! string operations
+ s1 & ! { dg-error "(A|a)ssumed.rank" }
+ = adjustr (s2) ! { dg-error "(A|a)ssumed.rank" }
+ i1 & ! { dg-error "(A|a)ssumed.rank" }
+ = index (c1, & ! { dg-error "(A|a)ssumed.rank" }
+ c2) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+
+ ! misc
+ i1 & ! { dg-error "(A|a)ssumed.rank" }
+ = cshift (i2, 4) ! { dg-error "(A|a)ssumed.rank" }
+ i = findloc (r1, 0.0) ! { dg-error "(A|a)ssumed.rank" }
+ r1 & ! { dg-error "(A|a)ssumed.rank" }
+ = matmul (r1, & ! { dg-error "(A|a)ssumed.rank" }
+ r2) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ r1 & ! { dg-error "(A|a)ssumed.rank" }
+ = reshape (r2, [10, 3]) ! { dg-error "(A|a)ssumed.rank" }
+ i1 & ! { dg-error "(A|a)ssumed.rank" }
+ = sign (i1, & ! { dg-error "(A|a)ssumed.rank" }
+ i2) ! { dg-error "(A|a)ssumed.rank" "pr101337, failure to diagnose both operands" { xfail *-*-*} }
+ s1 & ! { dg-error "(A|a)ssumed.rank" }
+ = transpose (s2) ! { dg-error "(A|a)ssumed.rank" }
+
+end subroutine
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535b-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535b-3.f90
new file mode 100644
index 00000000000..6427bd65803
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535b-3.f90
@@ -0,0 +1,79 @@
+! PR 101334
+! { dg-do compile}
+! { dg-additional-options "-fcoarray=single" }
+!
+! TS 29113
+! C535b An assumed-rank variable name shall not appear in a designator
+! or expression except as an actual argument corresponding to a dummy
+! argument that is assumed-rank, the argument of the C_LOC function
+! in the ISO_C_BINDING intrinsic module, or the first argument in a
+! reference to an intrinsic inquiry function.
+!
+! This has been renamed C838 in the Fortran 2018 standard, with C_SIZEOF
+! and SELECT_RANK additionally added.
+!
+! This tests various forms of the 2-argument associated intrinsic.
+
+function test_associated2 (a, b)
+ implicit none
+ integer, pointer :: a(..)
+ integer, target :: b(..)
+ logical :: test_associated2
+
+ test_associated2 = associated (a, b) ! { dg-error "Assumed.rank" }
+end function
+
+function test_associated3 (a, b)
+ implicit none
+ integer, pointer :: a(..)
+ integer, target :: b
+ logical :: test_associated3
+
+ test_associated3 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } }
+end function
+
+function test_associated4 (a, b)
+ implicit none
+ integer, pointer :: a(..)
+ integer, target :: b(:)
+ logical :: test_associated4
+
+ test_associated4 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } }
+end function
+
+function test_associated5 (a, b)
+ implicit none
+ integer, pointer :: a(..)
+ integer, target :: b(20)
+ logical :: test_associated5
+
+ test_associated5 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } }
+end function
+
+function test_associated6 (a, b)
+ implicit none
+ integer, pointer :: a(..)
+ integer, pointer :: b(..)
+ logical :: test_associated6
+
+ test_associated6 = associated (a, b) ! { dg-error "Assumed.rank" }
+end function
+
+function test_associated7 (a, b)
+ implicit none
+ integer, pointer :: a(..)
+ integer, pointer :: b
+ logical :: test_associated7
+
+ test_associated7 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } }
+end function
+
+function test_associated8 (a, b)
+ implicit none
+ integer, pointer :: a(..)
+ integer, pointer :: b(:)
+ logical :: test_associated8
+
+ test_associated8 = associated (a, b) ! { dg-bogus "must be of rank -1" "pr101334" { xfail *-*-* } }
+end function
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90
new file mode 100644
index 00000000000..b4047139eaf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90
@@ -0,0 +1,87 @@
+! PR 54753
+! { dg-do compile}
+!
+! TS 29113
+! C535c If an assumed-size or nonallocatable nonpointer assumed-rank
+! array is an actual argument corresponding to a dummy argument that
+! is an INTENT(OUT) assumed-rank array, it shall not be polymorphic, [...].
+!
+! This constraint is numbered C839 in the Fortran 2018 standard.
+!
+! This test file contains tests that are expected to issue diagnostics
+! for invalid code.
+
+module m
+
+ type :: t1
+ integer :: id
+ real :: xyz(3)
+ end type
+
+contains
+
+ subroutine s1_nonpolymorphic (x, y)
+ type(t1) :: x(..)
+ type(t1), intent(out) :: y(..)
+ end subroutine
+
+ subroutine s1_polymorphic (x, y) ! { dg-bogus "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+ class(t1) :: x(..)
+ class(t1), intent(out) :: y(..)
+ end subroutine
+
+ subroutine s1_unlimited_polymorphic (x, y) ! { dg-bogus "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+ class(*) :: x(..)
+ class(*), intent(out) :: y(..)
+ end subroutine
+
+ ! These calls should all be OK as they do not involve assumed-size or
+ ! assumed-rank actual arguments.
+ subroutine test_known_size (a1, a2, n)
+ integer :: n
+ type(t1) :: a1(n,n), a2(n)
+
+ call s1_nonpolymorphic (a1, a2)
+ call s1_polymorphic (a1, a2)
+ call s1_unlimited_polymorphic (a1, a2)
+ end subroutine
+
+ ! The calls to the polymorphic functions should be rejected
+ ! with an assumed-size array argument.
+ subroutine test_assumed_size (a1, a2)
+ type(t1) :: a1(*), a2(*)
+
+ call s1_nonpolymorphic (a1, a2)
+ call s1_polymorphic (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+ call s1_unlimited_polymorphic (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+ end subroutine
+
+ ! These calls should be OK.
+ subroutine test_assumed_rank_pointer (a1, a2)
+ type(t1), pointer :: a1(..), a2(..)
+
+ call s1_nonpolymorphic (a1, a2)
+ call s1_polymorphic (a1, a2)
+ call s1_unlimited_polymorphic (a1, a2)
+ end subroutine
+
+ ! These calls should be OK.
+ subroutine test_assumed_rank_allocatable (a1, a2)
+ type(t1), allocatable :: a1(..), a2(..)
+
+ call s1_nonpolymorphic (a1, a2)
+ call s1_polymorphic (a1, a2)
+ call s1_unlimited_polymorphic (a1, a2)
+ end subroutine
+
+ ! The calls to the polymorphic functions should be rejected
+ ! with a nonallocatable nonpointer assumed-rank actual argument.
+ subroutine test_assumed_rank_plain (a1, a2)
+ type(t1) :: a1(..), a2(..)
+
+ call s1_nonpolymorphic (a1, a2)
+ call s1_polymorphic (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+ call s1_unlimited_polymorphic (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+ end subroutine
+
+end module
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90
new file mode 100644
index 00000000000..db15ece9809
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90
@@ -0,0 +1,74 @@
+! PR 54753
+! { dg-do compile}
+!
+! TS 29113
+! C535c If an assumed-size or nonallocatable nonpointer assumed-rank
+! array is an actual argument corresponding to a dummy argument that
+! is an INTENT(OUT) assumed-rank array, it shall not be [...]
+! finalizable [...].
+!
+! This constraint is numbered C839 in the Fortran 2018 standard.
+!
+! This test file contains tests that are expected to issue diagnostics
+! for invalid code.
+
+module m
+
+ type :: t1
+ integer :: id
+ real :: xyz(3)
+ contains
+ final :: finalize_t1
+ end type
+
+contains
+
+ subroutine finalize_t1 (obj)
+ type(t1) :: obj
+ end subroutine
+
+ subroutine s1 (x, y)
+ type(t1) :: x(..)
+ type(t1), intent(out) :: y(..)
+ end subroutine
+
+ ! This call should be OK as it does not involve assumed-size or
+ ! assumed-rank actual arguments.
+ subroutine test_known_size (a1, a2, n)
+ integer :: n
+ type(t1) :: a1(n,n), a2(n)
+
+ call s1 (a1, a2)
+ end subroutine
+
+ ! Calls with an assumed-size array argument should be rejected.
+ subroutine test_assumed_size (a1, a2)
+ type(t1) :: a1(*), a2(*)
+
+ call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+ end subroutine
+
+ ! This call should be OK.
+ subroutine test_assumed_rank_pointer (a1, a2)
+ type(t1), pointer :: a1(..), a2(..)
+
+ call s1 (a1, a2)
+ end subroutine
+
+ ! This call should be OK.
+ subroutine test_assumed_rank_allocatable (a1, a2)
+ type(t1), allocatable :: a1(..), a2(..)
+
+ call s1 (a1, a2)
+ end subroutine
+
+ ! The call should be rejected with a nonallocatable nonpointer
+ ! assumed-rank actual argument.
+ subroutine test_assumed_rank_plain (a1, a2)
+ type(t1) :: a1(..), a2(..)
+
+ call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+ end subroutine
+
+end module
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90
new file mode 100644
index 00000000000..5c224b1f8bd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90
@@ -0,0 +1,73 @@
+! PR 54753
+! { dg-do compile }
+! { dg-ice "pr54753" }
+!
+! TS 29113
+! C535c If an assumed-size or nonallocatable nonpointer assumed-rank
+! array is an actual argument corresponding to a dummy argument that
+! is an INTENT(OUT) assumed-rank array, it shall not be [...]
+! of a type with an allocatable ultimate component [...].
+!
+! This constraint is numbered C839 in the Fortran 2018 standard.
+!
+! This test file contains tests that are expected to issue diagnostics
+! for invalid code.
+
+module m
+
+ type :: t1
+ integer :: id
+ real :: xyz(3)
+ character, allocatable :: notes
+ end type
+
+contains
+
+ subroutine finalize_t1 (obj)
+ type(t1) :: obj
+ end subroutine
+
+ subroutine s1 (x, y)
+ type(t1) :: x(..)
+ type(t1), intent(out) :: y(..)
+ end subroutine
+
+ ! This call should be OK as it does not involve assumed-size or
+ ! assumed-rank actual arguments.
+ subroutine test_known_size (a1, a2, n)
+ integer :: n
+ type(t1) :: a1(n,n), a2(n)
+
+ call s1 (a1, a2)
+ end subroutine
+
+ ! Calls with an assumed-size array argument should be rejected.
+ subroutine test_assumed_size (a1, a2)
+ type(t1) :: a1(*), a2(*)
+
+ call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+ end subroutine
+
+ ! This call should be OK.
+ subroutine test_assumed_rank_pointer (a1, a2)
+ type(t1), pointer :: a1(..), a2(..)
+
+ call s1 (a1, a2)
+ end subroutine
+
+ ! This call should be OK.
+ subroutine test_assumed_rank_allocatable (a1, a2)
+ type(t1), allocatable :: a1(..), a2(..)
+
+ call s1 (a1, a2)
+ end subroutine
+
+ ! The call should be rejected with a nonallocatable nonpointer
+ ! assumed-rank actual argument.
+ subroutine test_assumed_rank_plain (a1, a2)
+ type(t1) :: a1(..), a2(..)
+
+ call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+ end subroutine
+
+end module
diff --git a/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90
new file mode 100644
index 00000000000..ecbb18187dd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90
@@ -0,0 +1,73 @@
+! PR 54753
+! { dg-do compile }
+! { dg-ice "pr54753" }
+!
+! TS 29113
+! C535c If an assumed-size or nonallocatable nonpointer assumed-rank
+! array is an actual argument corresponding to a dummy argument that
+! is an INTENT(OUT) assumed-rank array, it shall not be [...]
+! of a type for which default initialization is specified.
+!
+! This constraint is numbered C839 in the Fortran 2018 standard.
+!
+! This test file contains tests that are expected to issue diagnostics
+! for invalid code.
+
+module m
+
+ type :: t1
+ integer :: id
+ real :: xyz(3)
+ integer :: tag = -1
+ end type
+
+contains
+
+ subroutine finalize_t1 (obj)
+ type(t1) :: obj
+ end subroutine
+
+ subroutine s1 (x, y)
+ type(t1) :: x(..)
+ type(t1), intent(out) :: y(..)
+ end subroutine
+
+ ! This call should be OK as it does not involve assumed-size or
+ ! assumed-rank actual arguments.
+ subroutine test_known_size (a1, a2, n)
+ integer :: n
+ type(t1) :: a1(n,n), a2(n)
+
+ call s1 (a1, a2)
+ end subroutine
+
+ ! Calls with an assumed-size array argument should be rejected.
+ subroutine test_assumed_size (a1, a2)
+ type(t1) :: a1(*), a2(*)
+
+ call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+ end subroutine
+
+ ! This call should be OK.
+ subroutine test_assumed_rank_pointer (a1, a2)
+ type(t1), pointer :: a1(..), a2(..)
+
+ call s1 (a1, a2)
+ end subroutine
+
+ ! This call should be OK.
+ subroutine test_assumed_rank_allocatable (a1, a2)
+ type(t1), allocatable :: a1(..), a2(..)
+
+ call s1 (a1, a2)
+ end subroutine
+
+ ! The call should be rejected with a nonallocatable nonpointer
+ ! assumed-rank actual argument.
+ subroutine test_assumed_rank_plain (a1, a2)
+ type(t1) :: a1(..), a2(..)
+
+ call s1 (a1, a2) ! { dg-error "(A|a)ssumed.rank" "pr54753" { xfail *-*-* } }
+ end subroutine
+
+end module
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-1-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-1-c.c
new file mode 100644
index 00000000000..3ff3a8d1ec8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-1-c.c
@@ -0,0 +1,91 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a);
+extern void ftest (CFI_cdesc_t *a, CFI_cdesc_t *b);
+
+struct m {
+ int i;
+ int j;
+};
+
+#define imax 10
+#define jmax 5
+
+void
+ctest (CFI_cdesc_t *a)
+{
+
+ struct m bdata[imax][jmax];
+ CFI_CDESC_T(2) bdesc;
+ CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
+ int i, j;
+ CFI_index_t subscripts[2];
+ struct m* mp;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ if (a->rank != 2)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ if (a->dim[0].extent != imax)
+ abort ();
+ if (a->dim[1].lower_bound != 0)
+ abort ();
+ if (a->dim[1].extent != jmax)
+ abort ();
+
+ /* Transpose a's contents into bdata. */
+ for (j = 0; j < jmax; j++)
+ {
+ subscripts[1] = j;
+ for (i = 0; i < imax; i++)
+ {
+ subscripts[0] = i;
+ mp = (struct m *) CFI_address (a, subscripts);
+ if (mp->i != i + 1)
+ abort ();
+ if (mp->j != j + 1)
+ abort ();
+ bdata[i][j].i = mp->i;
+ bdata[i][j].j = mp->j;
+ }
+ }
+
+ /* Fill in bdesc. */
+ subscripts[0] = jmax;
+ subscripts[1] = imax;
+ check_CFI_status ("CFI_establish",
+ CFI_establish (b, bdata, CFI_attribute_other,
+ CFI_type_struct,
+ sizeof (struct m), 2, subscripts));
+
+ /* Sanity checking to make sure the descriptor has been initialized
+ properly. */
+ dump_CFI_cdesc_t (b);
+ if (b->version != CFI_VERSION)
+ abort ();
+ if (b->rank != 2)
+ abort ();
+ if (b->attribute != CFI_attribute_other)
+ abort ();
+ if (b->dim[0].lower_bound != 0)
+ abort ();
+ if (b->dim[0].extent != jmax)
+ abort ();
+ if (b->dim[1].lower_bound != 0)
+ abort ();
+ if (b->dim[1].extent != imax)
+ abort ();
+
+ /* Call back into Fortran, passing both the a and b arrays. */
+ ftest (a, b);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-1.f90
new file mode 100644
index 00000000000..f52a631b157
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-1.f90
@@ -0,0 +1,66 @@
+! { dg-do run }
+! { dg-additional-sources "cf-descriptor-1-c.c dump-descriptors.c" }
+!
+! This program checks that building a descriptor for a fixed-size array
+! in C works and that you can use it to call back into a Fortran function
+! declared to have c binding, as an assumed-shape argument.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer, parameter :: imax=10, jmax=5
+end module
+
+subroutine ftest (a, b) bind (c, name="ftest")
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:), b(:,:)
+ integer :: i, j
+
+ if (size (a,1) .ne. imax) stop 101
+ if (size (a,2) .ne. jmax) stop 102
+ if (size (b,1) .ne. jmax) stop 103
+ if (size (b,2) .ne. imax) stop 104
+
+ do j = 1, jmax
+ do i = 1, imax
+ if (a(i,j)%i .ne. i) stop 201
+ if (a(i,j)%j .ne. j) stop 202
+ if (b(j,i)%i .ne. i) stop 203
+ if (b(j,i)%j .ne. j) stop 204
+ end do
+ end do
+end subroutine
+
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest (a) bind (c)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ end subroutine
+ end interface
+
+ type(m) :: aa(imax,jmax)
+ integer :: i, j
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = i
+ aa(i,j)%j = j
+ end do
+ end do
+
+ ! Pass the initialized array to a C function ctest, which will generate its
+ ! transpose and call ftest with it.
+
+ call ctest (aa)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-2-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-2-c.c
new file mode 100644
index 00000000000..a4be5a71dfc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-2-c.c
@@ -0,0 +1,91 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a);
+extern void ftest (CFI_cdesc_t *a, CFI_cdesc_t *b);
+
+struct m {
+ int i;
+ int j;
+};
+
+#define imax 10
+#define jmax 5
+
+void
+ctest (CFI_cdesc_t *a)
+{
+
+ struct m bdata[imax][jmax];
+ CFI_CDESC_T(2) bdesc;
+ CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
+ int i, j;
+ CFI_index_t subscripts[2];
+ struct m* mp;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ if (a->rank != 2)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ if (a->dim[0].extent != imax)
+ abort ();
+ if (a->dim[1].lower_bound != 0)
+ abort ();
+ if (a->dim[1].extent != jmax)
+ abort ();
+
+ /* Transpose a's contents into bdata. */
+ for (j = 0; j < jmax; j++)
+ {
+ subscripts[1] = j;
+ for (i = 0; i < imax; i++)
+ {
+ subscripts[0] = i;
+ mp = (struct m *) CFI_address (a, subscripts);
+ if (mp->i != i + 1)
+ abort ();
+ if (mp->j != j + 1)
+ abort ();
+ bdata[i][j].i = mp->i;
+ bdata[i][j].j = mp->j;
+ }
+ }
+
+ /* Fill in bdesc. */
+ subscripts[0] = jmax;
+ subscripts[1] = imax;
+ check_CFI_status ("CFI_establish",
+ CFI_establish (b, bdata, CFI_attribute_other,
+ CFI_type_struct,
+ sizeof (struct m), 2, subscripts));
+
+ /* Sanity checking to make sure the descriptor has been initialized
+ properly. */
+ dump_CFI_cdesc_t (b);
+ if (b->version != CFI_VERSION)
+ abort ();
+ if (b->rank != 2)
+ abort ();
+ if (b->attribute != CFI_attribute_other)
+ abort ();
+ if (b->dim[0].lower_bound != 0)
+ abort ();
+ if (b->dim[0].extent != jmax)
+ abort ();
+ if (b->dim[1].lower_bound != 0)
+ abort ();
+ if (b->dim[1].extent != imax)
+ abort ();
+
+ /* Call back into Fortran, passing both the a and b arrays. */
+ ftest (a, b);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-2.f90
new file mode 100644
index 00000000000..a4231fa6045
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-2.f90
@@ -0,0 +1,82 @@
+! PR 93308
+! { dg-do run }
+! { dg-additional-sources "cf-descriptor-2-c.c dump-descriptors.c" }
+!
+! This program checks that building a descriptor for a fixed-size array
+! in C works and that you can use it to call back into a Fortran function
+! declared to have c binding, as an assumed-rank argument.
+!
+! Fixed by
+! https://gcc.gnu.org/pipermail/gcc-patches/2021-June/572725.html
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer, parameter :: imax=10, jmax=5
+end module
+
+subroutine ftest (a, b) bind (c, name="ftest")
+ use iso_c_binding
+ use mm
+ type(m) :: a(..), b(..)
+ integer :: i, j
+
+ select rank (a)
+ rank (2)
+ select rank (b)
+ rank (2)
+ ! print *, lbound(a,1), ubound(a,1), lbound(a,2), ubound(a,2)
+ ! print *, lbound(b,1), ubound(b,1), lbound(b,2), ubound(b,2)
+ if (lbound (a,1) .ne. 1 .or. ubound (a,1) .ne. imax) stop 101
+ if (lbound (a,2) .ne. 1 .or. ubound (a,2) .ne. jmax) stop 102
+ if (lbound (b,1) .ne. 1 .or. ubound (b,1) .ne. jmax) stop 103
+ if (lbound (b,2) .ne. 1 .or. ubound (b,2) .ne. imax) stop 104
+ do j = 1, jmax
+ do i = 1, imax
+ print *, a(i,j)%i, a(i,j)%j, b(j,i)%i, b(j,i)%j
+ if (a(i,j)%i .ne. i) stop 105
+ if (a(i,j)%j .ne. j) stop 106
+ if (b(j,i)%i .ne. i) stop 107
+ if (b(j,i)%j .ne. j) stop 108
+ end do
+ end do
+ rank default
+ stop 106
+ end select
+ rank default
+ stop 107
+ end select
+end subroutine
+
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest (a) bind (c)
+ use iso_c_binding
+ use mm
+ type(m) :: a(..)
+ end subroutine
+ end interface
+
+ type(m) :: aa(imax,jmax)
+ integer :: i, j
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = i
+ aa(i,j)%j = j
+ end do
+ end do
+
+ ! Pass the initialized array to a C function ctest, which will generate its
+ ! transpose and call ftest with it.
+
+ call ctest (aa)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-3-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-3-c.c
new file mode 100644
index 00000000000..b947377b291
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-3-c.c
@@ -0,0 +1,92 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (int imagic, int jmagic);
+extern void ftest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp);
+
+struct m {
+ int i;
+ int j;
+};
+
+void
+ctest (int imagic, int jmagic)
+{
+ CFI_CDESC_T(0) adesc;
+ CFI_CDESC_T(0) bdesc;
+ CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc;
+ CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
+ struct m* mp;
+
+ /* Create the descriptor for a, then sanity-check it. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (a, NULL, CFI_attribute_allocatable,
+ CFI_type_struct,
+ sizeof (struct m), 0, NULL));
+ dump_CFI_cdesc_t (a);
+ if (a->version != CFI_VERSION)
+ abort ();
+ if (a->rank != 0)
+ abort ();
+ if (a->attribute != CFI_attribute_allocatable)
+ abort ();
+ if (a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof (struct m))
+ abort ();
+
+ /* Likewise for b. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (b, NULL, CFI_attribute_pointer,
+ CFI_type_struct,
+ sizeof (struct m), 0, NULL));
+ dump_CFI_cdesc_t (b);
+ if (b->version != CFI_VERSION)
+ abort ();
+ if (b->rank != 0)
+ abort ();
+ if (b->attribute != CFI_attribute_pointer)
+ abort ();
+ if (b->base_addr)
+ abort ();
+ if (b->elem_len != sizeof (struct m))
+ abort ();
+
+ /* Call back into Fortran, passing the unallocated descriptors. */
+ ftest (a, b, 0);
+
+ /* Allocate and initialize both variables, and try again. */
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (a, NULL, NULL, 0));
+ dump_CFI_cdesc_t (a);
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof (struct m))
+ abort ();
+ ((struct m *)a->base_addr)->i = imagic;
+ ((struct m *)a->base_addr)->j = jmagic;
+
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (b, NULL, NULL, 0));
+ dump_CFI_cdesc_t (b);
+ if (!b->base_addr)
+ abort ();
+ if (b->elem_len != sizeof (struct m))
+ abort ();
+ ((struct m *)b->base_addr)->i = imagic + 1;
+ ((struct m *)b->base_addr)->j = jmagic + 1;
+
+ ftest (a, b, 1);
+
+ /* Deallocate both objects and try again. */
+ check_CFI_status ("CFI_deallocate", CFI_deallocate (a));
+ if (a->base_addr)
+ abort ();
+ check_CFI_status ("CFI_deallocate", CFI_deallocate (b));
+ if (b->base_addr)
+ abort ();
+ ftest (a, b, 0);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-3.f90
new file mode 100644
index 00000000000..7a083950369
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-3.f90
@@ -0,0 +1,58 @@
+! { dg-do run }
+! { dg-additional-sources "cf-descriptor-3-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program checks that building a descriptor for an allocatable
+! or pointer scalar argument in C works and that you can use it to call
+! back into a Fortran function declared to have c binding.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer(C_INT), parameter :: imagic = 42, jmagic = 69
+end module
+
+subroutine ftest (a, b, initp) bind (c, name="ftest")
+ use iso_c_binding
+ use mm
+ type(m), allocatable :: a
+ type(m), pointer :: b
+ integer(C_INT), value :: initp
+
+ if (rank(a) .ne. 0) stop 101
+ if (rank(b) .ne. 0) stop 101
+
+ if (initp .ne. 0 .and. .not. allocated(a)) stop 102
+ if (initp .eq. 0 .and. allocated(a)) stop 103
+ if (initp .ne. 0 .and. .not. associated(b)) stop 104
+ if (initp .eq. 0 .and. associated(b)) stop 105
+
+ if (initp .ne. 0) then
+ if (a%i .ne. imagic) stop 201
+ if (a%j .ne. jmagic) stop 202
+ if (b%i .ne. imagic + 1) stop 203
+ if (b%j .ne. jmagic + 1) stop 204
+ end if
+end subroutine
+
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest (i, j) bind (c)
+ use iso_c_binding
+ integer(C_INT), value :: i, j
+ end subroutine
+ end interface
+
+ ! ctest will call ftest with both an unallocated and allocated argument.
+
+ call ctest (imagic, jmagic)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-4-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-4-c.c
new file mode 100644
index 00000000000..b941318ed24
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-4-c.c
@@ -0,0 +1,112 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (int imagic, int jmagic);
+extern void ftest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp);
+
+struct m {
+ int i;
+ int j;
+};
+
+void
+ctest (int imax, int jmax)
+{
+ CFI_CDESC_T(2) adesc;
+ CFI_CDESC_T(2) bdesc;
+ CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc;
+ CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
+ struct m* mp;
+ CFI_index_t lower[2], upper[2], subscripts[2];
+ CFI_index_t i, j;
+
+ /* Create the descriptor for a, then sanity-check it. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (a, NULL, CFI_attribute_allocatable,
+ CFI_type_struct,
+ sizeof (struct m), 2, NULL));
+ dump_CFI_cdesc_t (a);
+ if (a->version != CFI_VERSION)
+ abort ();
+ if (a->rank != 2)
+ abort ();
+ if (a->attribute != CFI_attribute_allocatable)
+ abort ();
+ if (a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof (struct m))
+ abort ();
+
+ /* Likewise for b. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (b, NULL, CFI_attribute_pointer,
+ CFI_type_struct,
+ sizeof (struct m), 2, NULL));
+ dump_CFI_cdesc_t (b);
+ if (b->version != CFI_VERSION)
+ abort ();
+ if (b->rank != 2)
+ abort ();
+ if (b->attribute != CFI_attribute_pointer)
+ abort ();
+ if (b->base_addr)
+ abort ();
+ if (b->elem_len != sizeof (struct m))
+ abort ();
+
+ /* Call back into Fortran, passing the unallocated descriptors. */
+ ftest (a, b, 0);
+
+ /* Allocate and initialize both variables, and try again. */
+ lower[0] = 1;
+ lower[1] = 1;
+ upper[0] = imax;
+ upper[1] = jmax;
+
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (a, lower, upper, 0));
+ dump_CFI_cdesc_t (a);
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof (struct m))
+ abort ();
+
+ upper[0] = jmax;
+ upper[1] = imax;
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (b, lower, upper, 0));
+ dump_CFI_cdesc_t (b);
+ if (!b->base_addr)
+ abort ();
+ if (b->elem_len != sizeof (struct m))
+ abort ();
+
+ for (i = 1; i <= imax; i++)
+ for (j = 1; j <= jmax; j++)
+ {
+ subscripts[0] = i;
+ subscripts[1] = j;
+ mp = (struct m *) CFI_address (a, subscripts);
+ mp->i = i;
+ mp->j = j;
+ subscripts[0] = j;
+ subscripts[1] = i;
+ mp = (struct m *) CFI_address (b, subscripts);
+ mp->i = i;
+ mp->j = j;
+ }
+
+ ftest (a, b, 1);
+
+ /* Deallocate both objects and try again. */
+ check_CFI_status ("CFI_deallocate", CFI_deallocate (a));
+ if (a->base_addr)
+ abort ();
+ check_CFI_status ("CFI_deallocate", CFI_deallocate (b));
+ if (b->base_addr)
+ abort ();
+ ftest (a, b, 0);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-4.f90
new file mode 100644
index 00000000000..c05f2e38dbc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-4.f90
@@ -0,0 +1,73 @@
+! { dg-do run }
+! { dg-additional-sources "cf-descriptor-4-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program checks that building a descriptor for an allocatable
+! or pointer array argument in C works and that you can use it to call
+! back into a Fortran function declared to have c binding.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer(C_INT), parameter :: imax=3, jmax=6
+end module
+
+subroutine ftest (a, b, initp) bind (c, name="ftest")
+ use iso_c_binding
+ use mm
+ type(m), allocatable :: a(:,:)
+ type(m), pointer :: b(:,:)
+ integer(C_INT), value :: initp
+ integer :: i, j
+
+ if (rank(a) .ne. 2) stop 101
+ if (rank(b) .ne. 2) stop 101
+
+ if (initp .ne. 0 .and. .not. allocated(a)) stop 102
+ if (initp .eq. 0 .and. allocated(a)) stop 103
+ if (initp .ne. 0 .and. .not. associated(b)) stop 104
+ if (initp .eq. 0 .and. associated(b)) stop 105
+
+ if (initp .ne. 0) then
+ if (lbound (a, 1) .ne. 1) stop 201
+ if (lbound (a, 2) .ne. 1) stop 202
+ if (lbound (b, 2) .ne. 1) stop 203
+ if (lbound (b, 1) .ne. 1) stop 204
+ if (ubound (a, 1) .ne. imax) stop 205
+ if (ubound (a, 2) .ne. jmax) stop 206
+ if (ubound (b, 2) .ne. imax) stop 207
+ if (ubound (b, 1) .ne. jmax) stop 208
+
+ do i = 1, imax
+ do j = 1, jmax
+ if (a(i,j)%i .ne. i) stop 301
+ if (a(i,j)%j .ne. j) stop 302
+ if (b(j,i)%i .ne. i) stop 303
+ if (b(j,i)%j .ne. j) stop 303
+ end do
+ end do
+
+ end if
+end subroutine
+
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest (i, j) bind (c)
+ use iso_c_binding
+ integer(C_INT), value :: i, j
+ end subroutine
+ end interface
+
+ ! ctest will call ftest with both an unallocated and allocated argument.
+
+ call ctest (imax, jmax)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5-c.c
new file mode 100644
index 00000000000..0cd92e78900
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5-c.c
@@ -0,0 +1,36 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (int n);
+extern void ftest (CFI_cdesc_t *a, int n);
+
+void
+ctest (int n)
+{
+ CFI_CDESC_T(0) adesc;
+ CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc;
+ char *adata = (char *) alloca (n);
+
+ /* Fill in adesc. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (a, adata, CFI_attribute_other,
+ CFI_type_char, n, 0, NULL));
+
+ /* Sanity checking to make sure the descriptor has been initialized
+ properly. */
+ dump_CFI_cdesc_t (a);
+ if (a->version != CFI_VERSION)
+ abort ();
+ if (a->rank != 0)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->elem_len != n)
+ abort ();
+
+ /* Call back into Fortran. */
+ ftest (a, n);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5.f90
new file mode 100644
index 00000000000..f178bb8d733
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5.f90
@@ -0,0 +1,31 @@
+! PR92482
+! { dg-do run }
+! { dg-additional-sources "cf-descriptor-5-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program checks that building a descriptor for a character object
+! 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 *-*-* } }
+ use iso_c_binding
+ character(kind=C_CHAR, len=*) :: a
+ integer(C_INT), value :: n
+
+ if (len (a) .ne. n) stop 101
+end subroutine
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest (n) bind (c)
+ use iso_c_binding
+ integer(C_INT), value :: n
+ end subroutine
+ end interface
+
+ call ctest (42)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-6-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-6-c.c
new file mode 100644
index 00000000000..168087be3ae
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-6-c.c
@@ -0,0 +1,81 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a, int lb1, int lb2, int ub1, int ub2, int step1, int step2);
+extern void ftest (CFI_cdesc_t *b);
+
+struct m {
+ int i;
+ int j;
+};
+
+void
+ctest (CFI_cdesc_t *a, int lb1, int lb2, int ub1, int ub2,
+ int step1, int step2)
+{
+ CFI_CDESC_T(2) bdesc;
+ CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
+ CFI_index_t lb[2], ub[2], step[2];
+ int i, j;
+
+ fprintf (stderr, "got new bound info (%d:%d:%d, %d:%d:%d)\n",
+ lb1, ub1, step1, lb2, ub2, step2);
+ lb[0] = lb1 - 1;
+ lb[1] = lb2 - 1;
+ ub[0] = ub1 - 1;
+ ub[1] = ub2 - 1;
+ step[0] = step1;
+ step[1] = step2;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ if (a->rank != 2)
+ abort ();
+
+ /* Fill in bdesc. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (b, NULL, CFI_attribute_pointer,
+ CFI_type_struct,
+ sizeof (struct m), 2, NULL));
+ check_CFI_status ("CFI_section",
+ CFI_section (b, a, lb, ub, step));
+
+ /* Sanity checking to make sure the descriptor has been initialized
+ properly. */
+ dump_CFI_cdesc_t (b);
+ if (b->version != CFI_VERSION)
+ abort ();
+ if (b->rank != 2)
+ abort ();
+ if (b->attribute != CFI_attribute_pointer)
+ abort ();
+ if (!b->base_addr)
+ abort ();
+ if (CFI_is_contiguous (b))
+ abort ();
+
+ for (j = b->dim[1].lower_bound;
+ j < b->dim[1].lower_bound + b->dim[1].extent;
+ j++)
+ {
+ for (i = b->dim[0].lower_bound;
+ i < b->dim[0].lower_bound + b->dim[0].extent;
+ i++)
+ {
+ CFI_index_t subscripts[2];
+ struct m *mp;
+ subscripts[0] = i;
+ subscripts[1] = j;
+ mp = (struct m *) CFI_address (b, subscripts);
+ fprintf (stderr, "b(%d,%d) = (%d,%d)\n", i, j, mp->i, mp->j);
+ }
+ }
+
+ /* Call back into Fortran. */
+ ftest (b);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-6.f90
new file mode 100644
index 00000000000..57164946090
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-6.f90
@@ -0,0 +1,72 @@
+! { dg-do run }
+! { dg-additional-sources "cf-descriptor-6-c.c dump-descriptors.c" }
+!
+! This program tests passing the result of the CFI_section C library
+! routine back to Fortran. Most of the work happens on the C side.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer, parameter :: imax=10, jmax=5
+ integer, parameter :: ilb=2, jlb=1
+ integer, parameter :: iub=8, jub=5
+ integer, parameter :: istep=3, jstep=2
+ integer, parameter :: isize=3, jsize=3
+end module
+
+subroutine ftest (b) bind (c, name="ftest")
+ use iso_c_binding
+ use mm
+ type(m), pointer :: b(:,:)
+ integer :: i, j, ii, jj
+
+ if (size (b, 1) .ne. isize) stop 103
+ if (size (b, 2) .ne. jsize) stop 104
+
+ ! ii and jj iterate over the elements of b
+ ! i and j iterate over the original array
+ jj = lbound (b, 2)
+ do j = jlb, jub, jstep
+ ii = lbound (b, 1)
+ do i = ilb, iub, istep
+ if (b (ii, jj)%i .ne. i) stop 203
+ if (b (ii, jj)%j .ne. j) stop 204
+ ii = ii + 1
+ end do
+ jj = jj + 1
+ end do
+end subroutine
+
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest (a, lb1, lb2, ub1, ub2, step1, step2) bind (c)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ integer(C_INT), value :: lb1, lb2, ub1, ub2, step1, step2
+ end subroutine
+ end interface
+
+ type(m), target :: aa(imax,jmax)
+ integer :: i, j
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = i
+ aa(i,j)%j = j
+ end do
+ end do
+
+ ! Pass the initialized array to a C function ctest, which will take
+ ! a section of it and pass it to ftest.
+
+ call ctest (aa, ilb, jlb, iub, jub, istep, jstep)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-7-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-7-c.c
new file mode 100644
index 00000000000..1f23a64a4b5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-7-c.c
@@ -0,0 +1,81 @@
+#include <stdlib.h>
+#include <stdio.h>
+#include <stddef.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a);
+extern void ftest (CFI_cdesc_t *iarray, CFI_cdesc_t *jarray);
+
+struct m {
+ int i;
+ int j;
+};
+
+void
+ctest (CFI_cdesc_t *a)
+{
+ CFI_CDESC_T(2) idesc;
+ CFI_cdesc_t *iarray = (CFI_cdesc_t *) &idesc;
+ CFI_CDESC_T(2) jdesc;
+ CFI_cdesc_t *jarray = (CFI_cdesc_t *) &jdesc;
+ int i, j;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ if (a->rank != 2)
+ abort ();
+
+ /* Fill in the new descriptors. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (iarray, NULL, CFI_attribute_pointer,
+ CFI_type_int,
+ sizeof (int), 2, NULL));
+ check_CFI_status ("CFI_select_part",
+ CFI_select_part (iarray, a, offsetof (struct m, i),
+ sizeof (int)));
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (jarray, NULL, CFI_attribute_pointer,
+ CFI_type_int,
+ sizeof (int), 2, NULL));
+ check_CFI_status ("CFI_select_part",
+ CFI_select_part (jarray, a, offsetof (struct m, j),
+ sizeof (int)));
+
+ /* Sanity checking to make sure the descriptor has been initialized
+ properly. */
+ dump_CFI_cdesc_t (iarray);
+ if (iarray->version != CFI_VERSION)
+ abort ();
+ if (iarray->rank != 2)
+ abort ();
+ if (iarray->attribute != CFI_attribute_pointer)
+ abort ();
+ if (!iarray->base_addr)
+ abort ();
+ if (iarray->dim[0].extent != a->dim[0].extent)
+ abort ();
+ if (iarray->dim[1].extent != a->dim[1].extent)
+ abort ();
+
+ dump_CFI_cdesc_t (jarray);
+ if (jarray->version != CFI_VERSION)
+ abort ();
+ if (jarray->rank != 2)
+ abort ();
+ if (jarray->attribute != CFI_attribute_pointer)
+ abort ();
+ if (!jarray->base_addr)
+ abort ();
+ if (jarray->dim[0].extent != a->dim[0].extent)
+ abort ();
+ if (jarray->dim[1].extent != a->dim[1].extent)
+ abort ();
+
+ /* Call back into Fortran. */
+ ftest (iarray, jarray);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-7.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-7.f90
new file mode 100644
index 00000000000..bc76b0eaa72
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-7.f90
@@ -0,0 +1,74 @@
+! { dg-do run }
+! { dg-additional-sources "cf-descriptor-7-c.c dump-descriptors.c" }
+!
+! This program tests passing the result of the CFI_select_part C library
+! routine back to Fortran. Most of the work happens on the C side.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer, parameter :: imax=10, jmax=5
+end module
+
+subroutine ftest (iarray, jarray) bind (c, name="ftest")
+ use iso_c_binding
+ use mm
+ integer(C_INT), pointer :: iarray(:,:), jarray(:,:)
+
+ integer :: i, j, i1, i2, j1, j2
+
+ ! iarray and jarray must have the same shape as the original array,
+ ! but might be zero-indexed instead of one-indexed.
+ if (size (iarray, 1) .ne. imax) stop 101
+ if (size (iarray, 2) .ne. jmax) stop 102
+ if (size (jarray, 1) .ne. imax) stop 103
+ if (size (jarray, 2) .ne. jmax) stop 104
+
+ j1 = lbound(iarray, 2)
+ j2 = lbound(jarray, 2)
+ do j = 1, jmax
+ i1 = lbound(iarray, 1)
+ i2 = lbound(jarray, 1)
+ do i = 1, imax
+ if (iarray (i1, j1) .ne. i) stop 201
+ if (jarray (i2, j2) .ne. j) stop 202
+ i1 = i1 + 1
+ i2 = i2 + 1
+ end do
+ j1 = j1 + 1
+ j2 = j2 + 1
+ end do
+end subroutine
+
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest (a) bind (c)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ end subroutine
+ end interface
+
+ type(m), target :: aa(imax,jmax)
+ integer :: i, j
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = i
+ aa(i,j)%j = j
+ end do
+ end do
+
+ ! Pass the initialized array to a C function ctest, which will split it
+ ! into i and j component arrays and pass them to ftest.
+
+ call ctest (aa)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-8-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-8-c.c
new file mode 100644
index 00000000000..49beee7f23b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-8-c.c
@@ -0,0 +1,73 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a);
+extern void ftest1 (CFI_cdesc_t *a, int lb1, int lb2);
+extern void ftest2 (CFI_cdesc_t *a);
+
+struct m {
+ int i;
+ int j;
+};
+
+#define imax 10
+#define jmax 5
+
+void
+ctest (CFI_cdesc_t *a)
+{
+
+ CFI_CDESC_T(2) bdesc;
+ CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
+ int i, j;
+ CFI_index_t subscripts[2];
+ struct m* mp;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ if (a->rank != 2)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+
+ /* Fill in bdesc. */
+ subscripts[0] = a->dim[0].extent;
+ subscripts[1] = a->dim[1].extent;
+ check_CFI_status ("CFI_establish",
+ CFI_establish (b, NULL, CFI_attribute_pointer,
+ CFI_type_struct,
+ sizeof (struct m), 2, subscripts));
+
+ /* Pass the unassociated pointer descriptor b back to Fortran for
+ checking. */
+ dump_CFI_cdesc_t (b);
+ ftest2 (b);
+
+ /* Point the descriptor b at the input argument array, and check that
+ on the Fortran side. */
+ subscripts[0] = a->dim[0].lower_bound;
+ subscripts[1] = a->dim[1].lower_bound;
+ check_CFI_status ("CFI_setpointer",
+ CFI_setpointer (b, a, subscripts));
+ dump_CFI_cdesc_t (b);
+ ftest1 (b, (int)subscripts[0], (int)subscripts[1]);
+
+ /* Diddle the lower bounds and try again. */
+ subscripts[0] = 42;
+ subscripts[1] = -69;
+ check_CFI_status ("CFI_setpointer",
+ CFI_setpointer (b, b, subscripts));
+ dump_CFI_cdesc_t (b);
+ ftest1 (b, 42, -69);
+
+ /* Disassociate the pointer and check that. */
+ check_CFI_status ("CFI_setpointer",
+ CFI_setpointer (b, NULL, NULL));
+ dump_CFI_cdesc_t (b);
+ ftest2 (b);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-8.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-8.f90
new file mode 100644
index 00000000000..6b35e6e8a2f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-8.f90
@@ -0,0 +1,78 @@
+! { dg-do run }
+! { dg-additional-sources "cf-descriptor-8-c.c dump-descriptors.c" }
+!
+! This program tests passing the result of the CFI_setpointer C library
+! function back to Fortran. Most of the work happens on the C side.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer, parameter :: imax=10, jmax=5
+end module
+
+subroutine ftest1 (a, lb1, lb2) bind (c, name="ftest1")
+ use iso_c_binding
+ use mm
+ type(m), pointer :: a(:,:)
+ integer(C_INT), value :: lb1, lb2
+ integer :: i, j, ii, jj
+
+ if (size (a,1) .ne. imax) stop 101
+ if (size (a,2) .ne. jmax) stop 102
+ if (lbound (a, 1) .ne. lb1) stop 103
+ if (lbound (a, 2) .ne. lb2) stop 104
+
+ if (.not. associated (a)) stop 105
+
+ jj = lb2
+ do j = 1, jmax
+ ii = lb1
+ do i = 1, imax
+ if (a(ii,jj)%i .ne. i) stop 201
+ if (a(ii,jj)%j .ne. j) stop 202
+ ii = ii + 1
+ end do
+ jj = jj + 1
+ end do
+end subroutine
+
+subroutine ftest2 (a) bind (c, name="ftest2")
+ use iso_c_binding
+ use mm
+ type(m), pointer :: a(:,:)
+
+ if (associated (a)) stop 301
+end subroutine
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest (a) bind (c)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ end subroutine
+ end interface
+
+ type(m), target :: aa(imax,jmax)
+ integer :: i, j
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = i
+ aa(i,j)%j = j
+ end do
+ end do
+
+ ! Pass the initialized array to a C function ctest, which will use it
+ ! as the target of a pointer array with various bounds, calling
+ ! ftest1 and ftest2 to check that CFI_setpointer did the right thing.
+
+ call ctest (aa)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-1-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-1-c.c
new file mode 100644
index 00000000000..366ec2b6144
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-1-c.c
@@ -0,0 +1,87 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a, CFI_cdesc_t *b);
+extern void ftest2 (CFI_cdesc_t *a, CFI_cdesc_t *b);
+
+struct m {
+ int i;
+ int j;
+};
+
+#define imax 10
+#define jmax 5
+
+void
+ctest (CFI_cdesc_t *a, CFI_cdesc_t *b)
+{
+ CFI_index_t i, j;
+ CFI_index_t s[2];
+ struct m *mpa, *mpb;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+ if (a->rank != 2)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ if (a->dim[0].extent != imax)
+ abort ();
+ if (a->dim[1].lower_bound != 0)
+ abort ();
+ if (a->dim[1].extent != jmax)
+ abort ();
+
+ dump_CFI_cdesc_t (b);
+ if (b->rank != 2)
+ abort ();
+ if (b->attribute != CFI_attribute_other)
+ abort ();
+ if (b->dim[0].lower_bound != 0)
+ abort ();
+ if (b->dim[0].extent != jmax)
+ abort ();
+ if (b->dim[1].lower_bound != 0)
+ abort ();
+ if (b->dim[1].extent != imax)
+ abort ();
+
+ /* Call back into Fortran, passing both the a and b arrays. */
+ ftest2 (a, b);
+
+ /* Check that we got a valid b array back. */
+ dump_CFI_cdesc_t (b);
+ if (b->rank != 2)
+ abort ();
+ if (b->attribute != CFI_attribute_other)
+ abort ();
+ if (b->dim[0].lower_bound != 0)
+ abort ();
+ if (b->dim[0].extent != jmax)
+ abort ();
+ if (b->dim[1].lower_bound != 0)
+ abort ();
+ if (b->dim[1].extent != imax)
+ abort ();
+
+ for (j = 0; j < jmax; j++)
+ for (i = 0; i < imax; i++)
+ {
+ s[0] = i;
+ s[1] = j;
+ mpa = (struct m *) CFI_address (a, s);
+ s[0] = j;
+ s[1] = i;
+ mpb = (struct m *) CFI_address (b, s);
+ if (mpa->i != mpb->i)
+ abort ();
+ if (mpa->j != mpb->j)
+ abort ();
+ }
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-1.f90
new file mode 100644
index 00000000000..05fe26c8a59
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-1.f90
@@ -0,0 +1,174 @@
+! { dg-do run }
+! { dg-additional-sources "cf-out-descriptor-1-c.c dump-descriptors.c" }
+!
+! This program checks that calling a Fortran function with C binding and
+! an intent(out) argument works from both C and Fortran. For this
+! test case the argument is an assumed-shape array.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer, parameter :: imax=10, jmax=5
+end module
+
+! frob has regular Fortran binding. It transposes input array argument
+! a into the intent(out) argument b.
+
+subroutine frob (a, b)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ type(m), intent(out) :: b(:,:)
+ integer :: i, j
+
+ if (lbound (a, 1) .ne. lbound (b, 2)) stop 101
+ if (lbound (a, 2) .ne. lbound (b, 1)) stop 102
+ if (ubound (a, 1) .ne. ubound (b, 2)) stop 103
+ if (ubound (a, 2) .ne. ubound (b, 1)) stop 104
+
+ do j = lbound (a, 2), ubound (a, 2)
+ do i = lbound (a, 1), ubound (a, 1)
+ b(j,i) = a(i,j)
+ end do
+ end do
+end subroutine
+
+! check also has regular Fortran binding, and two input arguments.
+
+subroutine check (a, b)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:), b(:,:)
+ integer :: i, j
+
+ if (lbound (a, 1) .ne. 1 .or. lbound (b, 2) .ne. 1) stop 101
+ if (lbound (a, 2) .ne. 1 .or. lbound (b, 1) .ne. 1) stop 102
+ if (ubound (a, 1) .ne. ubound (b, 2)) stop 103
+ if (ubound (a, 2) .ne. ubound (b, 1)) stop 104
+
+ do j = 1, ubound (a, 2)
+ do i = 1, ubound (a, 1)
+ if (b(j,i)%i .ne. a(i,j)%i) stop 105
+ if (b(j,i)%j .ne. a(i,j)%j) stop 106
+ end do
+ end do
+end subroutine
+
+! ftest1 has C binding and calls frob. This allows us to test intent(out)
+! arguments passed back from Fortran binding to a Fortran function with C
+! binding.
+
+subroutine ftest1 (a, b) bind (c, name="ftest1")
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ type(m), intent(out) :: b(:,:)
+
+ interface
+ subroutine frob (a, b)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ type(m), intent(out) :: b(:,:)
+ end subroutine
+ subroutine check (a, b)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:), b(:,:)
+ end subroutine
+ end interface
+
+ call frob (a, b)
+ call check (a, b)
+end subroutine
+
+! ftest2 has C binding and calls ftest1. This allows us to test intent(out)
+! arguments passed between two Fortran functions with C binding.
+
+subroutine ftest2 (a, b) bind (c, name="ftest2")
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ type(m), intent(out) :: b(:,:)
+
+ interface
+ subroutine ftest1 (a, b) bind (c, name="ftest1")
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ type(m), intent(out) :: b(:,:)
+ end subroutine
+ subroutine check (a, b)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:), b(:,:)
+ end subroutine
+ end interface
+
+ call ftest1 (a, b)
+ call check (a, b)
+end subroutine
+
+! main calls ftest2 directly and also indirectly from a C function ctest.
+! The former allows us to test intent(out) arguments passed back from a
+! Fortran routine with C binding to a regular Fortran routine, and the
+! latter tests passing them back from Fortran to C and C to Fortran.
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ftest2 (a, b) bind (c, name="ftest2")
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ type(m), intent(out) :: b(:,:)
+ end subroutine
+ subroutine ctest (a, b) bind (c)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ type(m), intent(out) :: b(:,:)
+ end subroutine
+ subroutine check (a, b)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:), b(:,:)
+ end subroutine
+ end interface
+
+ type(m) :: aa(imax,jmax), bb(jmax,imax)
+ integer :: i, j
+
+ ! initialize
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = i
+ aa(i,j)%j = j
+ bb(j,i)%i = -1
+ bb(j,i)%j = -2
+ end do
+ end do
+
+ call ftest2 (aa, bb)
+ call check (aa, bb)
+
+ ! initialize again
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = i
+ aa(i,j)%j = j
+ bb(j,i)%i = -1
+ bb(j,i)%j = -2
+ end do
+ end do
+
+ call ctest (aa, bb)
+ call check (aa, bb)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-2-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-2-c.c
new file mode 100644
index 00000000000..366ec2b6144
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-2-c.c
@@ -0,0 +1,87 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a, CFI_cdesc_t *b);
+extern void ftest2 (CFI_cdesc_t *a, CFI_cdesc_t *b);
+
+struct m {
+ int i;
+ int j;
+};
+
+#define imax 10
+#define jmax 5
+
+void
+ctest (CFI_cdesc_t *a, CFI_cdesc_t *b)
+{
+ CFI_index_t i, j;
+ CFI_index_t s[2];
+ struct m *mpa, *mpb;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+ if (a->rank != 2)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ if (a->dim[0].extent != imax)
+ abort ();
+ if (a->dim[1].lower_bound != 0)
+ abort ();
+ if (a->dim[1].extent != jmax)
+ abort ();
+
+ dump_CFI_cdesc_t (b);
+ if (b->rank != 2)
+ abort ();
+ if (b->attribute != CFI_attribute_other)
+ abort ();
+ if (b->dim[0].lower_bound != 0)
+ abort ();
+ if (b->dim[0].extent != jmax)
+ abort ();
+ if (b->dim[1].lower_bound != 0)
+ abort ();
+ if (b->dim[1].extent != imax)
+ abort ();
+
+ /* Call back into Fortran, passing both the a and b arrays. */
+ ftest2 (a, b);
+
+ /* Check that we got a valid b array back. */
+ dump_CFI_cdesc_t (b);
+ if (b->rank != 2)
+ abort ();
+ if (b->attribute != CFI_attribute_other)
+ abort ();
+ if (b->dim[0].lower_bound != 0)
+ abort ();
+ if (b->dim[0].extent != jmax)
+ abort ();
+ if (b->dim[1].lower_bound != 0)
+ abort ();
+ if (b->dim[1].extent != imax)
+ abort ();
+
+ for (j = 0; j < jmax; j++)
+ for (i = 0; i < imax; i++)
+ {
+ s[0] = i;
+ s[1] = j;
+ mpa = (struct m *) CFI_address (a, s);
+ s[0] = j;
+ s[1] = i;
+ mpb = (struct m *) CFI_address (b, s);
+ if (mpa->i != mpb->i)
+ abort ();
+ if (mpa->j != mpb->j)
+ abort ();
+ }
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-2.f90
new file mode 100644
index 00000000000..3b166f46b53
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-2.f90
@@ -0,0 +1,157 @@
+! { dg-do run }
+! { dg-additional-sources "cf-out-descriptor-2-c.c dump-descriptors.c" }
+!
+! This program checks that calling a Fortran function with C binding and
+! an intent(out) argument works from both C and Fortran. For this
+! test case the argument is an assumed-rank array.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer, parameter :: imax=10, jmax=5
+end module
+
+! The call chains we'll be testing will be
+! main -> ctest -> ftest1
+! main -> ftest2 -> ftest1
+! main -> ftest1
+! where everything has "c" binding except main.
+
+! ftest1 has C binding and transposes a into b.
+
+subroutine ftest1 (a, b) bind (c, name="ftest1")
+ use iso_c_binding
+ use mm
+ type(m) :: a(..)
+ type(m), intent(out) :: b(..)
+
+ select rank (a)
+ rank (2)
+ select rank (b)
+ rank (2)
+ b = transpose (a)
+ rank default
+ stop 101
+ end select
+ rank default
+ stop 102
+ end select
+end subroutine
+
+! ftest2 has C binding and calls ftest1.
+
+subroutine ftest2 (a, b) bind (c, name="ftest2")
+ use iso_c_binding
+ use mm
+ type(m) :: a(..)
+ type(m), intent(out) :: b(..)
+
+ interface
+ subroutine ftest1 (a, b) bind (c, name="ftest1")
+ use iso_c_binding
+ use mm
+ type(m) :: a(..)
+ type(m), intent(out) :: b(..)
+ end subroutine
+ end interface
+
+ call ftest1 (a, b)
+ if (rank (a) .ne. 2) stop 201
+ if (rank (b) .ne. 2) stop 202
+end subroutine
+
+! main calls ftest2 directly and also indirectly from a C function ctest.
+! The former allows us to test intent(out) arguments passed back from a
+! Fortran routine with C binding to a regular Fortran routine, and the
+! latter tests passing them back from Fortran to C and C to Fortran.
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ftest1 (a, b) bind (c, name="ftest2")
+ use iso_c_binding
+ use mm
+ type(m) :: a(..)
+ type(m), intent(out) :: b(..)
+ end subroutine
+ subroutine ftest2 (a, b) bind (c, name="ftest2")
+ use iso_c_binding
+ use mm
+ type(m) :: a(..)
+ type(m), intent(out) :: b(..)
+ end subroutine
+ subroutine ctest (a, b) bind (c, name="ctest")
+ use iso_c_binding
+ use mm
+ type(m) :: a(..)
+ type(m), intent(out) :: b(..)
+ end subroutine
+ end interface
+
+ type(m) :: aa(imax,jmax), bb(jmax,imax)
+ integer :: i, j
+
+ ! initialize
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = i
+ aa(i,j)%j = j
+ bb(j,i)%i = -1
+ bb(j,i)%j = -2
+ end do
+ end do
+
+ ! frob and check
+ call ftest1 (aa, bb)
+ do j = 1, jmax
+ do i = 1, imax
+ if (aa(i,j)%i .ne. bb(j,i)%i) stop 301
+ if (aa(i,j)%j .ne. bb(j,i)%j) stop 302
+ end do
+ end do
+
+ ! initialize again
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = i
+ aa(i,j)%j = j
+ bb(j,i)%i = -1
+ bb(j,i)%j = -2
+ end do
+ end do
+
+ ! frob and check
+ call ftest2 (aa, bb)
+ do j = 1, jmax
+ do i = 1, imax
+ if (aa(i,j)%i .ne. bb(j,i)%i) stop 401
+ if (aa(i,j)%j .ne. bb(j,i)%j) stop 402
+ end do
+ end do
+
+ ! initialize again
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = i
+ aa(i,j)%j = j
+ bb(j,i)%i = -1
+ bb(j,i)%j = -2
+ end do
+ end do
+
+ ! frob and check
+ call ctest (aa, bb)
+ do j = 1, jmax
+ do i = 1, imax
+ if (aa(i,j)%i .ne. bb(j,i)%i) stop 501
+ if (aa(i,j)%j .ne. bb(j,i)%j) stop 502
+ end do
+ end do
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3-c.c
new file mode 100644
index 00000000000..b04293eab0c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3-c.c
@@ -0,0 +1,108 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (int imagic, int jmagic);
+extern void frob (CFI_cdesc_t *a, CFI_cdesc_t *aa, CFI_cdesc_t *p);
+
+struct m {
+ int i;
+ int j;
+};
+
+void
+ctest (int imagic, int jmagic)
+{
+ CFI_CDESC_T(0) adesc;
+ CFI_CDESC_T(0) aadesc;
+ CFI_CDESC_T(0) bdesc;
+ CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc;
+ CFI_cdesc_t *aa = (CFI_cdesc_t *) &aadesc;
+ CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
+
+ /* Create and sanity-check descriptors. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (a, NULL, CFI_attribute_allocatable,
+ CFI_type_struct,
+ sizeof (struct m), 0, NULL));
+ dump_CFI_cdesc_t (a);
+ if (a->version != CFI_VERSION)
+ abort ();
+ if (a->rank != 0)
+ abort ();
+ if (a->attribute != CFI_attribute_allocatable)
+ abort ();
+ if (a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof (struct m))
+ abort ();
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (aa, NULL, CFI_attribute_allocatable,
+ CFI_type_struct,
+ sizeof (struct m), 0, NULL));
+ dump_CFI_cdesc_t (aa);
+ if (aa->version != CFI_VERSION)
+ abort ();
+ if (aa->rank != 0)
+ abort ();
+ if (aa->attribute != CFI_attribute_allocatable)
+ abort ();
+ if (aa->base_addr)
+ abort ();
+ if (aa->elem_len != sizeof (struct m))
+ abort ();
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (aa, NULL, NULL, 0));
+ ((struct m *)aa->base_addr)->i = 0;
+ ((struct m *)aa->base_addr)->j = 0;
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (b, NULL, CFI_attribute_pointer,
+ CFI_type_struct,
+ sizeof (struct m), 0, NULL));
+ dump_CFI_cdesc_t (b);
+ if (b->version != CFI_VERSION)
+ abort ();
+ if (b->rank != 0)
+ abort ();
+ if (b->attribute != CFI_attribute_pointer)
+ abort ();
+ if (b->base_addr)
+ abort ();
+ if (b->elem_len != sizeof (struct m))
+ abort ();
+
+ /* Call back into Fortran, which will allocate and initialize the
+ objects. */
+ frob (a, aa, b);
+
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof (struct m))
+ abort ();
+ if (((struct m *)a->base_addr)->i != imagic)
+ abort ();
+ if (((struct m *)a->base_addr)->j != jmagic)
+ abort ();
+
+ if (!aa->base_addr)
+ abort ();
+ if (aa->elem_len != sizeof (struct m))
+ abort ();
+ if (((struct m *)aa->base_addr)->i != imagic)
+ abort ();
+ if (((struct m *)aa->base_addr)->j != jmagic)
+ abort ();
+
+ if (!b->base_addr)
+ abort ();
+ if (b->elem_len != sizeof (struct m))
+ abort ();
+ if (((struct m *)b->base_addr)->i != imagic)
+ abort ();
+ if (((struct m *)b->base_addr)->j != jmagic)
+ abort ();
+}
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
new file mode 100644
index 00000000000..5e5f5955973
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3.f90
@@ -0,0 +1,134 @@
+! PR 92621 (?)
+! { dg-do run { xfail *-*-* } }
+! { dg-additional-sources "cf-out-descriptor-3-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program checks that calling a Fortran function with C binding and
+! an intent(out) argument works from both C and Fortran. For this
+! test case the argument is an allocatable or pointer scalar.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer, parameter :: imagic=-1, jmagic=42
+
+end module
+
+! The call chains being tested here are
+! main -> frob
+! main -> ftest -> frob
+! main -> ctest -> frob
+! where everything other than main has C binding.
+
+! frob allocates and initializes its arguments.
+! There are two allocatable dummies so that we can pass both
+! unallocated (a) and allocated (aa).
+
+subroutine frob (a, aa, p) bind (c, name="frob")
+ use iso_c_binding
+ use mm
+ type(m), intent(out), allocatable :: a, aa
+ type(m), intent(out), pointer :: p
+
+ if (allocated (a)) stop 101
+ allocate (a)
+ a%i = imagic
+ a%j = jmagic
+
+ if (allocated (aa)) stop 102
+ allocate (aa)
+ aa%i = imagic
+ aa%j = jmagic
+
+ ! association status of p is undefined on entry
+ allocate (p)
+ p%i = imagic
+ p%j = jmagic
+end subroutine
+
+subroutine ftest () bind (c, name="ftest")
+ use iso_c_binding
+ use mm
+ type(m), allocatable :: a, aa
+ type(m), pointer :: p
+
+ interface
+ subroutine frob (a, aa, p) bind (c, name="frob")
+ use iso_c_binding
+ use mm
+ type(m), intent(out), allocatable :: a, aa
+ type(m), intent(out), pointer :: p
+ end subroutine
+ end interface
+
+ p => NULL ()
+ allocate (aa)
+ aa%i = 0
+ aa%j = 0
+ call frob (a, aa, p)
+
+ if (.not. allocated (a)) stop 201
+ if (a%i .ne. imagic) stop 202
+ if (a%j .ne. jmagic) stop 203
+
+ if (.not. allocated (aa)) stop 204
+ if (a%i .ne. imagic) stop 205
+ if (a%j .ne. jmagic) stop 206
+
+ if (.not. associated (p)) stop 207
+ if (p%i .ne. imagic) stop 208
+ if (p%j .ne. jmagic) stop 209
+
+end subroutine
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine frob (a, aa, p) bind (c, name="frob")
+ use iso_c_binding
+ use mm
+ type(m), intent(out), allocatable :: a, aa
+ type(m), intent(out), pointer :: p
+ end subroutine
+ subroutine ftest () bind (c, name="ftest")
+ use iso_c_binding
+ use mm
+ end subroutine
+ subroutine ctest (ii, jj) bind (c, name="ctest")
+ use iso_c_binding
+ use mm
+ integer(C_INT), value :: ii, jj
+ end subroutine
+ end interface
+
+ type(m), allocatable :: a, aa
+ type(m), pointer :: p
+
+ p => NULL ()
+ allocate (aa)
+ aa%i = 0
+ aa%j = 0
+ call frob (a, aa, p)
+
+ if (.not. allocated (a)) stop 201
+ if (a%i .ne. imagic) stop 202
+ if (a%j .ne. jmagic) stop 203
+
+ if (.not. allocated (aa)) stop 204
+ if (a%i .ne. imagic) stop 205
+ if (a%j .ne. jmagic) stop 206
+
+ if (.not. associated (p)) stop 207
+ if (p%i .ne. imagic) stop 208
+ if (p%j .ne. jmagic) stop 209
+
+ call ftest
+ call ctest (imagic, jmagic)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4-c.c
new file mode 100644
index 00000000000..bf5db6f7bd7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4-c.c
@@ -0,0 +1,175 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (int imax, int jmax);
+extern void frob (CFI_cdesc_t *a, CFI_cdesc_t *aa, CFI_cdesc_t *p);
+
+struct m {
+ int i;
+ int j;
+};
+
+void
+ctest (int imax, int jmax)
+{
+ CFI_CDESC_T(2) adesc;
+ CFI_CDESC_T(2) aadesc;
+ CFI_CDESC_T(2) bdesc;
+ CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc;
+ CFI_cdesc_t *aa = (CFI_cdesc_t *) &aadesc;
+ CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
+ CFI_index_t i, j;
+ CFI_index_t s[2];
+ CFI_index_t lb[2], ub[2];
+ struct m* mp;
+
+ /* Create and sanity-check a. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (a, NULL, CFI_attribute_allocatable,
+ CFI_type_struct,
+ sizeof (struct m), 2, NULL));
+ dump_CFI_cdesc_t (a);
+ if (a->version != CFI_VERSION)
+ abort ();
+ if (a->rank != 2)
+ abort ();
+ if (a->attribute != CFI_attribute_allocatable)
+ abort ();
+ if (a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof (struct m))
+ abort ();
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (aa, NULL, CFI_attribute_allocatable,
+ CFI_type_struct,
+ sizeof (struct m), 2, NULL));
+ dump_CFI_cdesc_t (aa);
+ if (aa->version != CFI_VERSION)
+ abort ();
+ if (aa->rank != 2)
+ abort ();
+ if (aa->attribute != CFI_attribute_allocatable)
+ abort ();
+ if (aa->base_addr)
+ abort ();
+ if (aa->elem_len != sizeof (struct m))
+ abort ();
+
+ /* aa is allocated/initialized so that we can confirm that it's
+ magically deallocated when passed as intent(out). */
+ lb[0] = 0;
+ lb[1] = 0;
+ ub[0] = jmax;
+ ub[1] = jmax;
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (aa, lb, ub, 0));
+ for (j = 1; j <= jmax; j++)
+ for (i = 1; i <= imax; i++)
+ {
+ s[0] = j;
+ s[1] = i;
+ mp = (struct m *)CFI_address (aa, s);
+ mp->i = 0;
+ mp->j = 0;
+ }
+
+ /* Likewise create and sanity-check b. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (b, NULL, CFI_attribute_pointer,
+ CFI_type_struct,
+ sizeof (struct m), 2, NULL));
+ dump_CFI_cdesc_t (b);
+ if (b->version != CFI_VERSION)
+ abort ();
+ if (b->rank != 2)
+ abort ();
+ if (b->attribute != CFI_attribute_pointer)
+ abort ();
+ if (b->base_addr)
+ abort ();
+ if (b->elem_len != sizeof (struct m))
+ abort ();
+
+ /* Call back into Fortran, which will allocate and initialize the
+ objects. */
+ frob (a, aa, b);
+
+ dump_CFI_cdesc_t (a);
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof (struct m))
+ abort ();
+ if (a->dim[0].lower_bound != 1)
+ abort ();
+ if (a->dim[0].extent != imax)
+ abort ();
+ if (a->dim[1].lower_bound != 1)
+ abort ();
+ if (a->dim[1].extent != jmax)
+ abort ();
+ for (j = 1; j <= jmax; j++)
+ for (i = 1; i <= imax; i++)
+ {
+ s[0] = i;
+ s[1] = j;
+ mp = (struct m *)CFI_address (a, s);
+ if (mp->i != i)
+ abort ();
+ if (mp->j != j)
+ abort ();
+ }
+
+ dump_CFI_cdesc_t (aa);
+ if (!aa->base_addr)
+ abort ();
+ if (aa->elem_len != sizeof (struct m))
+ abort ();
+ if (aa->dim[0].lower_bound != 1)
+ abort ();
+ if (aa->dim[0].extent != imax)
+ abort ();
+ if (aa->dim[1].lower_bound != 1)
+ abort ();
+ if (aa->dim[1].extent != jmax)
+ abort ();
+ for (j = 1; j <= jmax; j++)
+ for (i = 1; i <= imax; i++)
+ {
+ s[0] = i;
+ s[1] = j;
+ mp = (struct m *)CFI_address (aa, s);
+ if (mp->i != i)
+ abort ();
+ if (mp->j != j)
+ abort ();
+ }
+
+ dump_CFI_cdesc_t (b);
+ if (!b->base_addr)
+ abort ();
+ if (b->elem_len != sizeof (struct m))
+ abort ();
+ if (b->dim[0].lower_bound != 1)
+ abort ();
+ if (b->dim[0].extent != jmax)
+ abort ();
+ if (b->dim[1].lower_bound != 1)
+ abort ();
+ if (b->dim[1].extent != imax)
+ abort ();
+ for (j = 1; j <= jmax; j++)
+ for (i = 1; i <= imax; i++)
+ {
+ s[0] = j;
+ s[1] = i;
+ mp = (struct m *)CFI_address (b, s);
+ if (mp->i != i)
+ abort ();
+ if (mp->j != j)
+ abort ();
+ }
+}
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
new file mode 100644
index 00000000000..082610c2da7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4.f90
@@ -0,0 +1,207 @@
+! PR 92621 (?)
+! { dg-do run { xfail *-*-* } }
+! { dg-additional-sources "cf-out-descriptor-4-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program checks that calling a Fortran function with C binding and
+! an intent(out) argument works from both C and Fortran. For this
+! test case the argument is an allocatable or pointer array.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer, parameter :: imax=5, jmax=10
+
+end module
+
+! The call chains being tested here are
+! main -> frob
+! main -> ftest -> frob
+! main -> ctest -> frob
+! where everything other than main has C binding.
+
+! frob allocates and initializes its arguments.
+! There are two allocatable dummies so that we can pass both
+! unallocated (a) and allocated (aa).
+
+subroutine frob (a, aa, p) bind (c, name="frob")
+ use iso_c_binding
+ use mm
+ type(m), intent(out), allocatable :: a(:,:), aa(:,:)
+ type(m), intent(out), pointer :: p(:,:)
+ integer :: i, j
+
+ if (allocated (a)) stop 101
+ allocate (a (imax, jmax))
+ do j = 1, jmax
+ do i = 1, imax
+ a(i,j)%i = i
+ a(i,j)%j = j
+ end do
+ end do
+
+ if (allocated (aa)) stop 102
+ allocate (aa (imax, jmax))
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = i
+ aa(i,j)%j = j
+ end do
+ end do
+
+ allocate (p (jmax, imax))
+ do j = 1, jmax
+ do i = 1, imax
+ p(j,i)%i = i
+ p(j,i)%j = j
+ end do
+ end do
+end subroutine
+
+subroutine ftest () bind (c, name="ftest")
+ use iso_c_binding
+ use mm
+ type(m), allocatable :: a(:,:), aa(:,:)
+ type(m), pointer :: p(:,:)
+
+ integer :: i, j
+
+ interface
+ subroutine frob (a, aa, p) bind (c, name="frob")
+ use iso_c_binding
+ use mm
+ type(m), intent(out), allocatable :: a(:,:), aa(:,:)
+ type(m), intent(out), pointer :: p(:,:)
+ end subroutine
+ end interface
+
+ p => NULL ()
+ if (allocated (a) .or. allocated (aa)) stop 200
+ allocate (aa (jmax, imax))
+ do j = 1, jmax
+ do i = 1, imax
+ aa(j,i)%i = 0
+ aa(j,i)%j = 0
+ end do
+ end do
+ call frob (a, aa, p)
+
+ if (.not. allocated (a)) stop 201
+ if (lbound (a, 1) .ne. 1) stop 202
+ if (lbound (a, 2) .ne. 1) stop 203
+ if (ubound (a, 1) .ne. imax) stop 204
+ if (ubound (a, 2) .ne. jmax) stop 205
+ do j = 1, jmax
+ do i = 1, imax
+ if (a(i,j)%i .ne. i) stop 206
+ if (a(i,j)%j .ne. j) stop 207
+ end do
+ end do
+
+ if (.not. allocated (aa)) stop 211
+ if (lbound (aa, 1) .ne. 1) stop 212
+ if (lbound (aa, 2) .ne. 1) stop 213
+ if (ubound (aa, 1) .ne. imax) stop 214
+ if (ubound (aa, 2) .ne. jmax) stop 215
+ do j = 1, jmax
+ do i = 1, imax
+ if (aa(i,j)%i .ne. i) stop 216
+ if (aa(i,j)%j .ne. j) stop 217
+ end do
+ end do
+
+ if (.not. associated (p)) stop 221
+ if (lbound (p, 1) .ne. 1) stop 222
+ if (lbound (p, 2) .ne. 1) stop 223
+ if (ubound (p, 1) .ne. jmax) stop 224
+ if (ubound (p, 2) .ne. imax) stop 225
+ do j = 1, jmax
+ do i = 1, imax
+ if (p(j,i)%i .ne. i) stop 226
+ if (p(j,i)%j .ne. j) stop 227
+ end do
+ end do
+
+end subroutine
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine frob (a, aa, p) bind (c, name="frob")
+ use iso_c_binding
+ use mm
+ type(m), intent(out), allocatable :: a(:,:), aa(:,:)
+ type(m), intent(out), pointer :: p(:,:)
+ end subroutine
+ subroutine ftest () bind (c, name="ftest")
+ use iso_c_binding
+ use mm
+ end subroutine
+ subroutine ctest (ii, jj) bind (c, name="ctest")
+ use iso_c_binding
+ use mm
+ integer(C_INT), value :: ii, jj
+ end subroutine
+ end interface
+
+ type(m), allocatable :: a(:,:), aa(:,:)
+ type(m), pointer :: p(:,:)
+ integer :: i, j
+
+ p => NULL ()
+ if (allocated (a) .or. allocated (aa)) stop 300
+ allocate (aa (jmax, imax))
+ do j = 1, jmax
+ do i = 1, imax
+ aa(j,i)%i = 0
+ aa(j,i)%j = 0
+ end do
+ end do
+ call frob (a, aa, p)
+
+ if (.not. allocated (a)) stop 301
+ if (lbound (a, 1) .ne. 1) stop 302
+ if (lbound (a, 2) .ne. 1) stop 303
+ if (ubound (a, 1) .ne. imax) stop 304
+ if (ubound (a, 2) .ne. jmax) stop 305
+ do j = 1, jmax
+ do i = 1, imax
+ if (a(i,j)%i .ne. i) stop 306
+ if (a(i,j)%j .ne. j) stop 307
+ end do
+ end do
+
+ if (.not. allocated (aa)) stop 311
+ if (lbound (aa, 1) .ne. 1) stop 312
+ if (lbound (aa, 2) .ne. 1) stop 313
+ if (ubound (aa, 1) .ne. imax) stop 314
+ if (ubound (aa, 2) .ne. jmax) stop 315
+ do j = 1, jmax
+ do i = 1, imax
+ if (aa(i,j)%i .ne. i) stop 316
+ if (aa(i,j)%j .ne. j) stop 317
+ end do
+ end do
+
+ if (.not. associated (p)) stop 321
+ if (lbound (p, 1) .ne. 1) stop 322
+ if (lbound (p, 2) .ne. 1) stop 323
+ if (ubound (p, 1) .ne. jmax) stop 324
+ if (ubound (p, 2) .ne. imax) stop 325
+ do j = 1, jmax
+ do i = 1, imax
+ if (p(j,i)%i .ne. i) stop 326
+ if (p(j,i)%j .ne. j) stop 327
+ end do
+ end do
+
+ call ftest
+ call ctest (imax, jmax)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5-c.c
new file mode 100644
index 00000000000..e5b37f35382
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5-c.c
@@ -0,0 +1,31 @@
+#include <stdlib.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a, int n);
+extern void ftest (CFI_cdesc_t *a, int n);
+
+void
+ctest (CFI_cdesc_t *a, int n)
+{
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ /* The actual argument object on the Fortran side has length n and
+ was passed as character(len=*).
+ Make sure that matches what's in the descriptor. */
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != n)
+ abort ();
+ if (a->rank != 0)
+ abort ();
+ if (a->type != CFI_type_char)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ ftest (a, n);
+}
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
new file mode 100644
index 00000000000..ff1e31d345f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5.f90
@@ -0,0 +1,48 @@
+! PR92482
+! { dg-do run }
+! { dg-additional-sources "cf-out-descriptor-5-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! 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 *-*-* } }
+ use iso_c_binding
+ character(kind=C_CHAR, len=*), intent(out) :: a
+ integer(C_INT), value :: n
+
+ if (len (a) .ne. n) stop 101
+ a = 'abcdefghijklmnopqrstuvwxyz'
+end subroutine
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest (a, n) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ 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 *-*-* } }
+ use iso_c_binding
+ character(kind=C_CHAR, len=*), intent(out) :: a
+ integer(C_INT), value :: n
+ end subroutine
+ end interface
+
+ character(kind=C_CHAR, len=42) :: aa
+
+ ! call ftest directly
+ aa = '12345678910'
+ call ftest (aa, 42)
+ print *, aa
+
+ ! ctest calls ftest indirectly
+ aa = '12345678910'
+ call ctest (aa, 42)
+ print *, aa
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6-c.c b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6-c.c
new file mode 100644
index 00000000000..f8724b95e89
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6-c.c
@@ -0,0 +1,42 @@
+#include <stdlib.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a, int n);
+extern void ftest (CFI_cdesc_t *a, int n);
+
+void
+ctest (CFI_cdesc_t *a, int n)
+{
+ int i;
+ CFI_index_t s[1];
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof(int))
+ abort ();
+ if (a->rank != 1)
+ abort ();
+ if (a->type != CFI_type_int)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ if (a->dim[0].extent != -1)
+ abort ();
+
+ ftest (a, n);
+
+ for (i = 0; i < n; i++)
+ {
+ s[0] = i;
+ if (*((int *)CFI_address (a, s)) != i + 1)
+ abort ();
+ }
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90
new file mode 100644
index 00000000000..b1a8c53b3e8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90
@@ -0,0 +1,115 @@
+! Reported as pr94070.
+! { dg-do run { xfail *-*-* } }
+! { dg-additional-sources "cf-out-descriptor-6-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program checks passing an assumed-size array as an intent(out)
+! argument to a bind (c) Fortran function from both C and Fortran.
+
+! Assumed-size arrays are not passed by descriptor. What we'll do
+! for this test function is pass the assumed-size array as the actual
+! argument corresponding to an assumed-rank dummy. This is supposed to
+! fill in the descriptor with information about the array present at
+! the call site.
+
+subroutine ftest (a, n) bind (c, name="ftest")
+ use iso_c_binding
+ integer(C_INT), intent(out) :: a(..)
+ integer(C_INT), value :: n
+ integer :: i
+
+ ! TS 29113
+ ! 6.4.2 SIZE
+ ! (1) for an assumed-rank object that is associated with an
+ ! assumed-size array, the result has the value −1 if DIM is
+ ! present and equal to the rank of ARRAY
+ if (rank (a) .ne. 1) stop 102
+ if (size (a, rank (a)) .ne. -1) stop 100
+ if (lbound (a, rank (a)) .ne. 1) stop 101
+
+ select rank (a)
+ rank (*)
+ do i = 1, n
+ a(i) = i
+ end do
+ rank default
+ stop 102
+ end select
+end subroutine
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest (a, n) bind (c, name="ctest")
+ use iso_c_binding
+ integer(C_INT), intent(out) :: a(..)
+ integer(C_INT), value :: n
+ end subroutine
+ subroutine ftest (a, n) bind (c, name="ftest")
+ use iso_c_binding
+ integer(C_INT), intent(out) :: a(..)
+ integer(C_INT), value :: n
+ end subroutine
+ end interface
+
+ integer(C_INT), target :: aa(10)
+
+ ! To get an assumed-size array descriptor, we have to first pass the
+ ! fixed-size array to a Fortran function with an assumed-size dummy,
+ call ftest1 (aa, 10) ! calls ftest
+ call ftest2 (aa, 10) ! has c binding, calls ftest
+ call ftest3 (aa, 10) ! calls ctest -> ftest
+ call ftest4 (aa, 10) ! has c binding, calls ctest -> ftest
+
+contains
+
+ subroutine ftest1 (a, n)
+ use iso_c_binding
+ integer(C_INT), intent(out) :: a(*)
+ integer(C_INT), value :: n
+ integer :: i
+ a(1:n) = 0
+ call ftest (a, n)
+ do i = 1, n
+ if (a (i) .ne. i) stop 200
+ end do
+ end subroutine
+
+ subroutine ftest2 (a, n) bind (c)
+ use iso_c_binding
+ integer(C_INT), intent(out) :: a(*)
+ integer(C_INT), value :: n
+ integer :: i
+ a(1:n) = 0
+ call ftest (a, n)
+ do i = 1, n
+ if (a (i) .ne. i) stop 201
+ end do
+ end subroutine
+
+ subroutine ftest3 (a, n)
+ use iso_c_binding
+ integer(C_INT), intent(out) :: a(*)
+ integer(C_INT), value :: n
+ integer :: i
+ a(1:n) = 0
+ call ctest (a, n)
+ do i = 1, n
+ if (a (i) .ne. i) stop 202
+ end do
+ end subroutine
+
+ subroutine ftest4 (a, n) bind (c)
+ use iso_c_binding
+ integer(C_INT), intent(out) :: a(*)
+ integer(C_INT), value :: n
+ integer :: i
+ a(1:n) = 0
+ call ctest (a, n)
+ do i = 1, n
+ if (a (i) .ne. i) stop 203
+ end do
+ end subroutine
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/contiguous-1-c.c b/gcc/testsuite/gfortran.dg/c-interop/contiguous-1-c.c
new file mode 100644
index 00000000000..6b30da48e5f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/contiguous-1-c.c
@@ -0,0 +1,56 @@
+#include <stdlib.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest1 (CFI_cdesc_t *a);
+extern void ctest2 (CFI_cdesc_t *a);
+
+static void
+ctest (CFI_cdesc_t *a)
+{
+ int i;
+ int *p;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ /* Make sure we got a valid descriptor. */
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof(int))
+ abort ();
+ if (a->rank != 1)
+ abort ();
+ if (a->type != CFI_type_int)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->dim[0].sm != sizeof(int))
+ abort ();
+ if (!CFI_is_contiguous (a))
+ abort ();
+
+ /* Negate the elements of the array. */
+ p = (int *)a->base_addr;
+ for (i = 0; i < a->dim[0].extent; i++)
+ p[i] = -p[i];
+}
+
+
+/* The two entry points are declared differently on the C side, but both
+ should do the same thing. */
+
+void
+ctest1 (CFI_cdesc_t *a)
+{
+ ctest (a);
+}
+
+void
+ctest2 (CFI_cdesc_t *a)
+{
+ ctest (a);
+}
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/contiguous-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/contiguous-1.f90
new file mode 100644
index 00000000000..fe1c98294cd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/contiguous-1.f90
@@ -0,0 +1,67 @@
+! { dg-do run }
+! { dg-additional-sources "contiguous-1-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! TS 29113
+! 8.7 In an invocation of an interoperable procedure whose Fortran
+! interface has an assumed-shape or assumed-rank dummy argument with the
+! CONTIGUOUS attribute, the associated effective argument may be an
+! array that is not contiguous or the address of a C descriptor for such
+! an array. If the procedure is invoked from Fortran or the procedure is
+! a Fortran procedure, the Fortran processor will handle the difference
+! in contiguity. If the procedure is invoked from C and the procedure is
+! a C procedure, the C code within the procedure shall be prepared to
+! handle the situation of receiving a discontiguous argument.
+!
+! This program tests the cases where Fortran code passes a non-contiguous
+! array section to a C function whose interface has the contiguous
+! attribute.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ ! ctest1 and ctest2 both negate the elements of their input array.
+ subroutine ctest1 (a) bind (c)
+ use iso_c_binding
+ integer(C_INT), contiguous :: a(:)
+ end subroutine
+ subroutine ctest2 (a) bind (c)
+ use iso_c_binding
+ integer(C_INT), contiguous :: a(..)
+ end subroutine
+ end interface
+
+ integer(C_INT) :: aa(32)
+ integer :: i
+
+ ! assumed-shape
+ do i = 1, 32
+ aa(i) = i
+ end do
+ call ctest1 (aa(4:12:2))
+ do i = 1, 32
+ if (i .ge. 4 .and. i .le. 12 .and. mod (i-4,2) .eq. 0) then
+ if (aa (i) .ne. -i) stop 101
+ else
+ if (aa (i) .ne. i) stop 102
+ end if
+ end do
+
+ ! assumed-rank
+ do i = 1, 32
+ aa(i) = i
+ end do
+ call ctest2 (aa(7:19:3))
+ do i = 1, 32
+ if (i .ge. 7 .and. i .le. 19 .and. mod (i-7,3) .eq. 0) then
+ if (aa (i) .ne. -i) stop 201
+ else
+ if (aa (i) .ne. i) stop 202
+ end if
+ end do
+
+end program
+
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/contiguous-2-c.c b/gcc/testsuite/gfortran.dg/c-interop/contiguous-2-c.c
new file mode 100644
index 00000000000..5a8f3d6669f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/contiguous-2-c.c
@@ -0,0 +1,113 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest1 (CFI_cdesc_t *a);
+extern void ctest2 (CFI_cdesc_t *a);
+extern void ftest1 (CFI_cdesc_t *a, int first, int last, int step);
+extern void ftest2 (CFI_cdesc_t *a, int first, int last, int step);
+
+#if 0
+static void
+dump_array (CFI_cdesc_t *a, const char *name, const char *note)
+{
+ int i;
+
+ fprintf (stderr, "%s\n", note);
+ for (i = 0; i < a->dim[0].extent; i++)
+ {
+ int j = i + a->dim[0].lower_bound;
+ int elt;
+ CFI_index_t sub[1];
+ sub[0] = j;
+ elt = *((int *) CFI_address (a, sub));
+ fprintf (stderr, "%s[%d] = %d\n", name, j, elt);
+ }
+ fprintf (stderr, "\n");
+}
+#else
+#define dump_array(a, name, note)
+#endif
+
+static void
+ctest (CFI_cdesc_t *a, int lb, int ub, int s,
+ void (*fn) (CFI_cdesc_t *, int, int, int))
+{
+ CFI_CDESC_T(1) bdesc;
+ CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
+ CFI_index_t lb_array[1], ub_array[1], s_array[1];
+ int i;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ /* Make sure we got a valid descriptor. */
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof(int))
+ abort ();
+ if (a->rank != 1)
+ abort ();
+ if (a->type != CFI_type_int)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+
+ /* Create an array section and pass it to fn. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (b, NULL, CFI_attribute_other,
+ CFI_type_int,
+ sizeof (int), 1, NULL));
+ lb_array[0] = lb - 1 + a->dim[0].lower_bound;
+ ub_array[0] = ub - 1 + a->dim[0].lower_bound;
+ s_array[0] = s;
+ check_CFI_status ("CFI_section",
+ CFI_section (b, a, lb_array, ub_array, s_array));
+ dump_CFI_cdesc_t (b);
+ dump_array (b, "b", "b after CFI_section");
+
+ /* Pass it to the Fortran function fn. */
+ if (CFI_is_contiguous (b))
+ abort ();
+ (*fn) (b, lb, ub, s);
+ dump_CFI_cdesc_t (b);
+ dump_array (b, "b", "b after calling Fortran fn");
+
+ /* fn is supposed to negate the elements of the array section it
+ receives. Check that the original array has been updated. */
+ dump_array (a, "a", "a after calling Fortran fn");
+ for (i = 0; i < a->dim[0].extent; i++)
+ {
+ int elt;
+ int j = i + a->dim[0].lower_bound;
+ CFI_index_t sub[1];
+ sub[0] = j;
+ elt = *((int *) CFI_address (a, sub));
+ if (i + 1 >= lb && i + 1 <= ub && (i + 1 - lb) % s == 0)
+ {
+ if (elt != - (i + 1))
+ abort ();
+ }
+ else if (elt != (i + 1))
+ abort ();
+ }
+}
+
+
+/* Entry points for the Fortran side. */
+
+void
+ctest1 (CFI_cdesc_t *a)
+{
+ ctest (a, 5, 13, 2, ftest1);
+}
+
+void
+ctest2 (CFI_cdesc_t *a)
+{
+ ctest (a, 8, 20, 3, ftest2);
+}
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/contiguous-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/contiguous-2.f90
new file mode 100644
index 00000000000..bb8ba20a5b2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/contiguous-2.f90
@@ -0,0 +1,152 @@
+! PR 101304
+! { dg-do run { xfail *-*-* } }
+! { dg-additional-sources "contiguous-2-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! TS 29113
+! 8.7 In an invocation of an interoperable procedure whose Fortran
+! interface has an assumed-shape or assumed-rank dummy argument with the
+! CONTIGUOUS attribute, the associated effective argument may be an
+! array that is not contiguous or the address of a C descriptor for such
+! an array. If the procedure is invoked from Fortran or the procedure is
+! a Fortran procedure, the Fortran processor will handle the difference
+! in contiguity. If the procedure is invoked from C and the procedure is
+! a C procedure, the C code within the procedure shall be prepared to
+! handle the situation of receiving a discontiguous argument.
+!
+! The wording is different in the 2018 standard, but the intent is more
+! or less the same:
+!
+! When an interoperable Fortran procedure that is invoked from C has a
+! dummy argument with the CONTIGUOUS attribute or that is an assumed-length
+! CHARACTER explicit-shape or assumed-size array, and the actual argument
+! is the address of a C descriptor for a discontiguous object, the Fortran
+! processor shall handle the difference in contiguity.
+!
+! This program tests the cases where a Fortran procedure with C binding and
+! a dummy array argument with the contiguous attribute is invoked from
+! both C or Fortran.
+
+! ftest1 and ftest2 both negate the elements of their input array;
+! this allows testing that modifications to the array contents get
+! propagated back to the base array.
+
+module m
+
+ contains
+
+ subroutine ftest1 (a, first, last, step) bind (c)
+ use iso_c_binding
+ integer(C_INT), contiguous :: a(:)
+ integer(C_INT), value :: first, last, step
+ integer :: i, ival
+
+ ! Sanity checking that we got a contiguous array. The direct call
+ ! to is_contiguous might be optimized away, but the indirect one
+ ! in check_contiguous shouldn't be.
+ ! FIXME: is this correct? "the Fortran processor will handle the
+ ! difference in contiguity" may not mean that it's required to make
+ ! the array contiguous, just that it can access it correctly?
+ if (.not. is_contiguous (a)) stop 301
+ call check_contiguous (a)
+
+ ! Sanity checking that we got the right input array contents.
+ ! print *, 'a on entry to ftest1'
+ ! do i = lbound(a, 1), ubound(a, 1)
+ ! print *, 'a(', i, ') = ', a(i)
+ ! end do
+ ival = first
+ do i = lbound(a, 1), ubound(a, 1)
+ if (a (i) .ne. ival) then
+ print *, 'a(', i, ') = ', a(i), ' expected ', ival
+ stop 302
+ end if
+ a(i) = - a(i)
+ ival = ival + step
+ end do
+ end subroutine
+
+ subroutine ftest2 (a, first, last, step) bind (c)
+ use iso_c_binding
+
+ integer(C_INT), contiguous :: a(..)
+ integer(C_INT), value :: first, last, step
+
+ select rank (a)
+ rank (1)
+ call ftest1 (a(:), first, last, step)
+ rank default
+ stop 303
+ end select
+ end subroutine
+
+ subroutine check_contiguous (a)
+ use iso_c_binding
+ integer(C_INT) :: a(..)
+ if (.not. is_contiguous (a)) stop 304
+ end subroutine
+
+end module
+
+
+program testit
+ use iso_c_binding
+ use m
+ implicit none
+
+ interface
+ subroutine ctest1 (a) bind (c)
+ use iso_c_binding
+ integer(C_INT) :: a(:)
+ end subroutine
+ subroutine ctest2 (a) bind (c)
+ use iso_c_binding
+ integer(C_INT) :: a(..)
+ end subroutine
+ end interface
+
+ integer(C_INT) :: aa(32)
+ integer :: i
+
+ ! assumed-shape, called from Fortran
+ do i = 1, 32
+ aa(i) = i
+ end do
+ call ftest1 (aa(4:12:2), 4, 12, 2)
+ do i = 1, 32
+ if (i .ge. 4 .and. i .le. 12 .and. mod (i-4,2) .eq. 0) then
+ if (aa (i) .ne. -i) stop 101
+ else
+ if (aa (i) .ne. i) stop 102
+ end if
+ end do
+
+ ! assumed-shape, called from C code which will use the C interface
+ ! to create a non-contiguous array section and pass it to ftest1.
+ do i = 1, 32
+ aa(i) = i
+ end do
+ call ctest1 (aa)
+
+ ! assumed-rank, called from Fortran
+ do i = 1, 32
+ aa(i) = i
+ end do
+ call ftest2 (aa(7:19:3), 7, 19, 3)
+ do i = 1, 32
+ if (i .ge. 7 .and. i .le. 19 .and. mod (i-7,3) .eq. 0) then
+ if (aa (i) .ne. -i) stop 201
+ else
+ if (aa (i) .ne. i) stop 202
+ end if
+ end do
+
+ ! assumed-rank, called from C code which will use the C interface
+ ! to create a non-contiguous array section and pass it to ftest2.
+ do i = 1, 32
+ aa(i) = i
+ end do
+ call ctest2 (aa)
+
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/contiguous-3-c.c b/gcc/testsuite/gfortran.dg/c-interop/contiguous-3-c.c
new file mode 100644
index 00000000000..b124476f8f0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/contiguous-3-c.c
@@ -0,0 +1,80 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest1 (CFI_cdesc_t *a, int first, int last, int step);
+extern void ctest2 (CFI_cdesc_t *a, int first, int last, int step);
+extern void ftest1 (CFI_cdesc_t *a, int first, int last, int step);
+extern void ftest2 (CFI_cdesc_t *a, int first, int last, int step);
+
+#if 0
+static void
+dump_array (CFI_cdesc_t *a, const char *name, const char *note)
+{
+ int i;
+
+ fprintf (stderr, "%s\n", note);
+ for (i = 0; i < a->dim[0].extent; i++)
+ {
+ int j = i + a->dim[0].lower_bound;
+ int elt;
+ CFI_index_t sub[1];
+ sub[0] = j;
+ elt = *((int *) CFI_address (a, sub));
+ fprintf (stderr, "%s[%d] = %d\n", name, j, elt);
+ }
+ fprintf (stderr, "\n");
+}
+#else
+#define dump_array(a, name, note)
+#endif
+
+static void
+ctest (CFI_cdesc_t *a, int first, int last, int step,
+ void (*fn) (CFI_cdesc_t *, int, int, int))
+{
+ int i;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+ dump_array (a, "a", "a on input to ctest");
+
+ /* Make sure we got a valid descriptor. */
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof(int))
+ abort ();
+ if (a->rank != 1)
+ abort ();
+ if (a->type != CFI_type_int)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+
+ /* Pass it to the Fortran function fn. */
+ (*fn) (a, first, last, step);
+ dump_CFI_cdesc_t (a);
+ dump_array (a, "a", "a after calling Fortran fn");
+}
+
+/* Entry points for the Fortran side.
+ Note that the Fortran code has already created the array section
+ and these functions were declared without the CONTIGUOUS attribute
+ so they receive a non-contiguous array. The magic is supposed to
+ happen when we pass them back into a Fortran function declared with
+ the CONTIGUOUS attribute. */
+
+void
+ctest1 (CFI_cdesc_t *a, int first, int last, int step)
+{
+ ctest (a, first, last, step, ftest1);
+}
+
+void
+ctest2 (CFI_cdesc_t *a, int first, int last, int step)
+{
+ ctest (a, first, last, step, ftest2);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/contiguous-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/contiguous-3.f90
new file mode 100644
index 00000000000..9a6d66b14fd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/contiguous-3.f90
@@ -0,0 +1,171 @@
+! PR 101304
+! { dg-do run { xfail *-*-* } }
+! { dg-additional-sources "contiguous-3-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! TS 29113
+! 8.7 In an invocation of an interoperable procedure whose Fortran
+! interface has an assumed-shape or assumed-rank dummy argument with the
+! CONTIGUOUS attribute, the associated effective argument may be an
+! array that is not contiguous or the address of a C descriptor for such
+! an array. If the procedure is invoked from Fortran or the procedure is
+! a Fortran procedure, the Fortran processor will handle the difference
+! in contiguity. If the procedure is invoked from C and the procedure is
+! a C procedure, the C code within the procedure shall be prepared to
+! handle the situation of receiving a discontiguous argument.
+!
+! The wording is different in the 2018 standard, but the intent is more
+! or less the same:
+!
+! When an interoperable Fortran procedure that is invoked from C has a
+! dummy argument with the CONTIGUOUS attribute or that is an assumed-length
+! CHARACTER explicit-shape or assumed-size array, and the actual argument
+! is the address of a C descriptor for a discontiguous object, the Fortran
+! processor shall handle the difference in contiguity.
+!
+! This program tests the cases where a Fortran procedure with C binding and
+! a dummy array argument with the contiguous attribute is invoked from
+! both C or Fortran. It is similar to contiguous-2.f90 but here the array
+! sections are created in Fortran even in the called-from-C case, rather
+! than by calling CFI_section.
+
+! ftest1 and ftest2 both negate the elements of their input array;
+! this allows testing that modifications to the array contents get
+! propagated back to the base array.
+
+module m
+
+ contains
+
+ subroutine ftest1 (a, first, last, step) bind (c)
+ use iso_c_binding
+ integer(C_INT), contiguous :: a(:)
+ integer(C_INT), value :: first, last, step
+ integer :: i, ival
+
+ ! Sanity checking that we got a contiguous array. The direct call
+ ! to is_contiguous might be optimized away, but the indirect one
+ ! in check_contiguous shouldn't be.
+ ! FIXME: is this correct? "the Fortran processor will handle the
+ ! difference in contiguity" may not mean that it's required to make
+ ! the array contiguous, just that it can access it correctly?
+ if (.not. is_contiguous (a)) stop 301
+ call check_contiguous (a)
+
+ ! Sanity checking that we got the right input array contents.
+ ! print *, 'a on entry to ftest1'
+ ! do i = lbound(a, 1), ubound(a, 1)
+ ! print *, 'a(', i, ') = ', a(i)
+ ! end do
+ ival = first
+ do i = lbound(a, 1), ubound(a, 1)
+ if (a (i) .ne. ival) then
+ print *, 'a(', i, ') = ', a(i), ' expected ', ival
+ stop 302
+ end if
+ a(i) = - a(i)
+ ival = ival + step
+ end do
+ end subroutine
+
+ subroutine ftest2 (a, first, last, step) bind (c)
+ use iso_c_binding
+
+ integer(C_INT), contiguous :: a(..)
+ integer(C_INT), value :: first, last, step
+
+ select rank (a)
+ rank (1)
+ call ftest1 (a(:), first, last, step)
+ rank default
+ stop 303
+ end select
+ end subroutine
+
+ subroutine check_contiguous (a)
+ use iso_c_binding
+ integer(C_INT) :: a(..)
+ if (.not. is_contiguous (a)) stop 304
+ end subroutine
+
+end module
+
+
+program testit
+ use iso_c_binding
+ use m
+ implicit none
+
+ ! Note ctest1 and ctest2 do not have the contiguous attribute on a.
+ interface
+ subroutine ctest1 (a, first, last, step) bind (c)
+ use iso_c_binding
+ integer(C_INT) :: a(:)
+ integer(C_INT), value :: first, last, step
+ end subroutine
+ subroutine ctest2 (a, first, last, step) bind (c)
+ use iso_c_binding
+ integer(C_INT) :: a(..)
+ integer(C_INT), value :: first, last, step
+ end subroutine
+ end interface
+
+ integer(C_INT) :: aa(32)
+ integer :: i
+
+ ! assumed-shape, called from Fortran
+ do i = 1, 32
+ aa(i) = i
+ end do
+ call ftest1 (aa(4:12:2), 4, 12, 2)
+ do i = 1, 32
+ if (i .ge. 4 .and. i .le. 12 .and. mod (i-4,2) .eq. 0) then
+ if (aa (i) .ne. -i) stop 101
+ else
+ if (aa (i) .ne. i) stop 102
+ end if
+ end do
+
+ ! assumed-shape, called indirectly from C code, using an array
+ ! section created in Fortran instead of by CFI_section
+ do i = 1, 32
+ aa(i) = i
+ end do
+ call ctest1 (aa(5:13:2), 5, 13, 2)
+ do i = 1, 32
+ if (i .ge. 5 .and. i .le. 13 .and. mod (i-5,2) .eq. 0) then
+ if (aa (i) .ne. -i) stop 103
+ else
+ if (aa (i) .ne. i) stop 104
+ end if
+ end do
+
+ ! assumed-rank, called from Fortran
+ do i = 1, 32
+ aa(i) = i
+ end do
+ call ftest2 (aa(7:19:3), 7, 19, 3)
+ do i = 1, 32
+ if (i .ge. 7 .and. i .le. 19 .and. mod (i-7,3) .eq. 0) then
+ if (aa (i) .ne. -i) stop 201
+ else
+ if (aa (i) .ne. i) stop 202
+ end if
+ end do
+
+ ! assumed-rank, called indirectly from C code, using an array
+ ! section created in Fortran instead of by CFI_section
+ do i = 1, 32
+ aa(i) = i
+ end do
+ call ctest2 (aa(8:20:3), 8, 20, 3)
+ do i = 1, 32
+ if (i .ge. 8 .and. i .le. 20 .and. mod (i-8,3) .eq. 0) then
+ if (aa (i) .ne. -i) stop 203
+ else
+ if (aa (i) .ne. i) stop 204
+ end if
+ end do
+
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/deferred-character-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/deferred-character-1.f90
new file mode 100644
index 00000000000..bd6d9cb3dd9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/deferred-character-1.f90
@@ -0,0 +1,76 @@
+! PR92482
+! { dg-do compile}
+!
+! TS 29113
+! 8.7 Interoperability of procedures and procedure interfaces
+!
+! If a dummy argument in an interoperable interface is of type
+! CHARACTER and is allocatable or a pointer, its character length shall
+! be deferred.
+!
+! This test checks that this error is diagnosed and is supposed to fail.
+
+module m
+ use iso_c_binding
+
+ interface
+
+ ! These are supposed to be OK
+ subroutine good1 (x, n) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ 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 *-*-* } }
+ use iso_c_binding
+ character (kind=C_CHAR, len=:), pointer :: x
+ integer(C_INT), value :: n
+ end subroutine
+
+ ! These are supposed to fail.
+ subroutine bad1 (x, n) bind (c) ! { dg-error "must have deferred length" }
+ use iso_c_binding
+ character (kind=C_CHAR, len=*), allocatable :: x
+ integer(C_INT), value :: n
+ end subroutine
+ subroutine bad2 (x, n) bind (c) ! { dg-error "must have deferred length" }
+ use iso_c_binding
+ character (kind=C_CHAR, len=*), pointer :: x
+ integer(C_INT), value :: n
+ end subroutine
+
+ subroutine bad3 (x, n) bind (c) ! { dg-error "must have deferred length" }
+ use iso_c_binding
+ character (kind=C_CHAR, len=80), allocatable :: x
+ integer(C_INT), value :: n
+ end subroutine
+ subroutine bad4 (x, n) bind (c) ! { dg-error "must have deferred length" }
+ use iso_c_binding
+ character (kind=C_CHAR, len=80), pointer :: x
+ integer(C_INT), value :: n
+ end subroutine
+
+ subroutine bad5 (x, n) bind (c) ! { dg-error "must have deferred length" }
+ use iso_c_binding
+ character (kind=C_CHAR, len=1), allocatable :: x
+ integer(C_INT), value :: n
+ end subroutine
+ subroutine bad6 (x, n) bind (c) ! { dg-error "must have deferred length" }
+ use iso_c_binding
+ character (kind=C_CHAR, len=1), pointer :: x
+ integer(C_INT), value :: n
+ end subroutine
+
+ subroutine bad7 (x, n) bind (c) ! { dg-error "must have deferred length" }
+ use iso_c_binding
+ character (kind=C_CHAR), allocatable :: x
+ integer(C_INT), value :: n
+ end subroutine
+ subroutine bad8 (x, n) bind (c) ! { dg-error "must have deferred length" }
+ use iso_c_binding
+ character (kind=C_CHAR), pointer :: x
+ integer(C_INT), value :: n
+ end subroutine
+ end interface
+
+end module
diff --git a/gcc/testsuite/gfortran.dg/c-interop/deferred-character-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/deferred-character-2.f90
new file mode 100644
index 00000000000..9fd046def4c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/deferred-character-2.f90
@@ -0,0 +1,55 @@
+! PR 92482
+! { dg-do execute}
+!
+! TS 29113
+! 8.7 Interoperability of procedures and procedure interfaces
+!
+! If a dummy argument in an interoperable interface is of type
+! CHARACTER and is allocatable or a pointer, its character length shall
+! be deferred.
+
+program testit
+ use iso_c_binding
+
+ character (kind=C_CHAR, len=:), allocatable :: aa
+ character (kind=C_CHAR, len=:), pointer :: pp
+
+
+ pp => NULL ()
+
+ call frobf (aa, pp)
+ if (.not. allocated (aa)) stop 101
+ if (aa .ne. 'foo') stop 102
+ if (.not. associated (pp)) stop 103
+ if (pp .ne. 'bar') stop 104
+
+ pp => NULL ()
+
+ call frobc (aa, pp)
+ if (.not. allocated (aa)) stop 101
+ if (aa .ne. 'frog') stop 102
+ if (.not. associated (pp)) stop 103
+ if (pp .ne. 'toad') stop 104
+
+
+ contains
+
+ subroutine frobf (a, p)
+ use iso_c_binding
+ character (kind=C_CHAR, len=:), allocatable :: a
+ character (kind=C_CHAR, len=:), pointer :: p
+ allocate (character(len=3) :: p)
+ a = 'foo'
+ p = 'bar'
+ end subroutine
+
+ subroutine frobc (a, p) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ use iso_c_binding
+ character (kind=C_CHAR, len=:), allocatable :: a
+ character (kind=C_CHAR, len=:), pointer :: p
+ allocate (character(len=4) :: p)
+ a = 'frog'
+ p = 'toad'
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/dump-descriptors.c b/gcc/testsuite/gfortran.dg/c-interop/dump-descriptors.c
new file mode 100644
index 00000000000..47e84e21c13
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/dump-descriptors.c
@@ -0,0 +1,195 @@
+/* This file contains some useful routines for debugging problems with C
+ descriptors. Compiling it also acts as a test that the implementation of
+ ISO_Fortran_binding.h provides all the types and constants specified in
+ TS29113. */
+
+#include <stdio.h>
+#include <stddef.h>
+#include <stdlib.h>
+#include "dump-descriptors.h"
+
+void
+dump_CFI_cdesc_t (CFI_cdesc_t *d)
+{
+ fprintf (stderr, "<CFI_cdesc_t base_addr=%p elem_len=%ld version=%d",
+ d->base_addr, (long)(d->elem_len), d->version);
+ fprintf (stderr, "\n rank=");
+ dump_CFI_rank_t (d->rank);
+ fprintf (stderr, " type=");
+ dump_CFI_type_t (d->type);
+ fprintf (stderr, " attribute=");
+ dump_CFI_attribute_t (d->attribute);
+
+ /* Dimension info may not be initialized if it's an allocatable
+ or pointer descriptor with a null base_addr. */
+ if (d->rank > 0 && d->base_addr)
+ {
+ CFI_rank_t i;
+ for (i = 0; i < d->rank; i++)
+ {
+ if (i == 0)
+ fprintf (stderr, "\n dim=[");
+ else
+ fprintf (stderr, ",\n ");
+ dump_CFI_dim_t (d->dim + i);
+ }
+ fprintf (stderr, "]");
+ }
+ fprintf (stderr, ">\n");
+}
+
+void
+dump_CFI_dim_t (CFI_dim_t *d)
+{
+ fprintf (stderr, "<CFI_dim_t lower_bound=");
+ dump_CFI_index_t (d->lower_bound);
+ fprintf (stderr, " extent=");
+ dump_CFI_index_t (d->extent);
+ fprintf (stderr, " sm=");
+ dump_CFI_index_t (d->sm);
+ fprintf (stderr, ">");
+}
+
+void
+dump_CFI_attribute_t (CFI_attribute_t a)
+{
+ switch (a)
+ {
+ case CFI_attribute_pointer:
+ fprintf (stderr, "CFI_attribute_pointer");
+ break;
+ case CFI_attribute_allocatable:
+ fprintf (stderr, "CFI_attribute_allocatable");
+ break;
+ case CFI_attribute_other:
+ fprintf (stderr, "CFI_attribute_other");
+ break;
+ default:
+ fprintf (stderr, "unknown(%d)", (int)a);
+ break;
+ }
+}
+
+void
+dump_CFI_index_t (CFI_index_t i)
+{
+ fprintf (stderr, "%ld", (long)i);
+}
+
+void
+dump_CFI_rank_t (CFI_rank_t r)
+{
+ fprintf (stderr, "%d", (int)r);
+}
+
+/* We can't use a switch statement to dispatch CFI_type_t because
+ the type name macros may not be unique. Iterate over a table
+ instead. */
+
+struct type_name_map {
+ CFI_type_t t;
+ const char *n;
+};
+
+struct type_name_map type_names[] =
+{
+ { CFI_type_signed_char, "CFI_type_signed_char" },
+ { CFI_type_short, "CFI_type_short" },
+ { CFI_type_int, "CFI_type_int" },
+ { CFI_type_long, "CFI_type_long" },
+ { CFI_type_long_long, "CFI_type_long_long" },
+ { CFI_type_size_t, "CFI_type_size_t" },
+ { CFI_type_int8_t, "CFI_type_int8_t" },
+ { CFI_type_int16_t, "CFI_type_int16_t" },
+ { CFI_type_int32_t, "CFI_type_int32_t" },
+ { CFI_type_int64_t, "CFI_type_int64_t" },
+ { CFI_type_int_least8_t, "CFI_type_int_least8_t" },
+ { CFI_type_int_least16_t, "CFI_type_int_least16_t" },
+ { CFI_type_int_least32_t, "CFI_type_int_least32_t" },
+ { CFI_type_int_least64_t, "CFI_type_int_least64_t" },
+ { CFI_type_int_fast8_t, "CFI_type_int_fast8_t" },
+ { CFI_type_int_fast16_t, "CFI_type_int_fast16_t" },
+ { CFI_type_int_fast32_t, "CFI_type_int_fast32_t" },
+ { CFI_type_int_fast64_t, "CFI_type_int_fast64_t" },
+ { CFI_type_intmax_t, "CFI_type_intmax_t" },
+ { CFI_type_intptr_t, "CFI_type_intptr_t" },
+ { CFI_type_ptrdiff_t, "CFI_type_ptrdiff_t" },
+ { CFI_type_float, "CFI_type_float" },
+ { CFI_type_double, "CFI_type_double" },
+ { CFI_type_long_double, "CFI_type_long_double" },
+ { CFI_type_float_Complex, "CFI_type_float_Complex" },
+ { CFI_type_double_Complex, "CFI_type_double_Complex" },
+ { CFI_type_long_double_Complex, "CFI_type_long_double_Complex" },
+ { CFI_type_Bool, "CFI_type_Bool" },
+ { CFI_type_char, "CFI_type_char" },
+ { CFI_type_cptr, "CFI_type_cptr" },
+ { CFI_type_struct, "CFI_type_struct" },
+ { CFI_type_other, "CFI_type_other" },
+ /* Extension types */
+ { CFI_type_int128_t, "CFI_type_int128_t" },
+ { CFI_type_int_least128_t, "CFI_type_int_least128_t" },
+ { CFI_type_int_fast128_t, "CFI_type_int_fast128_t" },
+ { CFI_type_ucs4_char, "CFI_type_ucs4_char" },
+ { CFI_type_float128, "CFI_type_float128" },
+ { CFI_type_float128_Complex, "CFI_type_float128_Complex" },
+ { CFI_type_cfunptr, "CFI_type_cfunptr" }
+};
+
+void
+dump_CFI_type_t (CFI_type_t t)
+{
+ int i;
+ for (i = 0; i < sizeof (type_names) / sizeof (struct type_name_map); i++)
+ if (type_names[i].t == t)
+ {
+ fprintf (stderr, "%s", type_names[i].n);
+ return;
+ }
+ fprintf (stderr, "unknown(%d)", (int)t);
+}
+
+void
+check_CFI_status (const char *fn, int code)
+{
+ const char *msg;
+ switch (code)
+ {
+ case CFI_SUCCESS:
+ return;
+ case CFI_ERROR_BASE_ADDR_NULL:
+ msg = "CFI_ERROR_BASE_ADDR_NULL";
+ break;
+ case CFI_ERROR_BASE_ADDR_NOT_NULL:
+ msg = "CFI_ERROR_BASE_ADDR_NOT_NULL";
+ break;
+ case CFI_INVALID_ELEM_LEN:
+ msg = "CFI_INVALID_ELEM_LEN";
+ break;
+ case CFI_INVALID_RANK:
+ msg = "CFI_INVALID_RANK";
+ break;
+ case CFI_INVALID_TYPE:
+ msg = "CFI_INVALID_TYPE";
+ break;
+ case CFI_INVALID_ATTRIBUTE:
+ msg = "CFI_INVALID_ATTRIBUTE";
+ break;
+ case CFI_INVALID_EXTENT:
+ msg = "CFI_INVALID_EXTENT";
+ break;
+ case CFI_INVALID_DESCRIPTOR:
+ msg = "CFI_INVALID_DESCRIPTOR";
+ break;
+ case CFI_ERROR_MEM_ALLOCATION:
+ msg = "CFI_ERROR_MEM_ALLOCATION";
+ break;
+ case CFI_ERROR_OUT_OF_BOUNDS:
+ msg = "CFI_ERROR_OUT_OF_BOUNDS";
+ break;
+ default:
+ msg = "unknown error";
+ break;
+ }
+ fprintf (stderr, "%s returned %s\n", fn, msg);
+ abort ();
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/dump-descriptors.h b/gcc/testsuite/gfortran.dg/c-interop/dump-descriptors.h
new file mode 100644
index 00000000000..52375a9bdac
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/dump-descriptors.h
@@ -0,0 +1,12 @@
+/* Definitions of functions in dump-descriptors.c. */
+
+#include "ISO_Fortran_binding.h"
+
+extern void dump_CFI_cdesc_t (CFI_cdesc_t *d);
+extern void dump_CFI_dim_t (CFI_dim_t *d);
+extern void dump_CFI_attribute_t (CFI_attribute_t a);
+extern void dump_CFI_index_t (CFI_index_t i);
+extern void dump_CFI_rank_t (CFI_rank_t r);
+extern void dump_CFI_type_t (CFI_type_t t);
+
+void check_CFI_status (const char *fn, int code);
diff --git a/gcc/testsuite/gfortran.dg/c-interop/establish-c.c b/gcc/testsuite/gfortran.dg/c-interop/establish-c.c
new file mode 100644
index 00000000000..9e7900de7df
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/establish-c.c
@@ -0,0 +1,134 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+/* For simplicity, point descriptors at a static buffer. BUFSIZE should
+ be large enough for any of the standard types and we'll use DIM0 and DIM1
+ for array dimensions. */
+#define BUFSIZE 64
+#define DIM0 3
+#define DIM1 10
+#define ARRAYBUFSIZE BUFSIZE * DIM0 * DIM1
+static char *buf[ARRAYBUFSIZE] __attribute__ ((aligned (8)));
+static CFI_index_t extents[] = {DIM0, DIM1};
+
+/* Magic number to use for elem_len field. */
+#define MAGIC_ELEM_LEN 20
+
+struct tc_info
+{
+ CFI_type_t typecode;
+ char *name;
+ size_t size;
+};
+
+static struct tc_info tc_table[] =
+{
+ { CFI_type_signed_char, "CFI_type_signed_char", sizeof (signed char) },
+ { CFI_type_short, "CFI_type_short", sizeof (short) },
+ { CFI_type_int, "CFI_type_int", sizeof (int) },
+ { CFI_type_long, "CFI_type_long", sizeof (long) },
+ { CFI_type_long_long, "CFI_type_long_long", sizeof (long long) },
+ { CFI_type_size_t, "CFI_type_size_t", sizeof (size_t) },
+ { CFI_type_int8_t, "CFI_type_int8_t", sizeof (int8_t) },
+ { CFI_type_int16_t, "CFI_type_int16_t", sizeof (int16_t) },
+ { CFI_type_int32_t, "CFI_type_int32_t", sizeof (int32_t) },
+ { CFI_type_int64_t, "CFI_type_int64_t", sizeof (int64_t) },
+ { CFI_type_int_least8_t, "CFI_type_int_least8_t", sizeof (int_least8_t) },
+ { CFI_type_int_least16_t, "CFI_type_int_least16_t", sizeof (int_least16_t) },
+ { CFI_type_int_least32_t, "CFI_type_int_least32_t", sizeof (int_least32_t) },
+ { CFI_type_int_least64_t, "CFI_type_int_least64_t", sizeof (int_least64_t) },
+ { CFI_type_int_fast8_t, "CFI_type_int_fast8_t", sizeof (int_fast8_t) },
+ { CFI_type_int_fast16_t, "CFI_type_int_fast16_t", sizeof (int_fast16_t) },
+ { CFI_type_int_fast32_t, "CFI_type_int_fast32_t", sizeof (int_fast32_t) },
+ { CFI_type_int_fast64_t, "CFI_type_int_fast64_t", sizeof (int_fast64_t) },
+ { CFI_type_intmax_t, "CFI_type_intmax_t", sizeof (intmax_t) },
+ { CFI_type_intptr_t, "CFI_type_intptr_t", sizeof (intptr_t) },
+ { CFI_type_ptrdiff_t, "CFI_type_ptrdiff_t", sizeof (ptrdiff_t) },
+ { CFI_type_float, "CFI_type_float", sizeof (float) },
+ { CFI_type_double, "CFI_type_double", sizeof (double) },
+ { CFI_type_long_double, "CFI_type_long_double", sizeof (long double) },
+ { CFI_type_float_Complex, "CFI_type_float_Complex",
+ sizeof (float _Complex) },
+ { CFI_type_double_Complex, "CFI_type_double_Complex",
+ sizeof (double _Complex) },
+ { CFI_type_long_double_Complex, "CFI_type_long_double_Complex",
+ sizeof (long double _Complex) },
+ { CFI_type_Bool, "CFI_type_Bool", sizeof (_Bool) },
+ { CFI_type_char, "CFI_type_char", sizeof (char) },
+ { CFI_type_cptr, "CFI_type_cptr", sizeof (void *) },
+ { CFI_type_struct, "CFI_type_struct", 0 },
+ { CFI_type_other, "CFI_type_other", -1 }
+};
+
+int
+test_array (struct tc_info *tc, void *ptr, CFI_attribute_t attr)
+{
+ CFI_CDESC_T(2) desc;
+ CFI_cdesc_t *a = (CFI_cdesc_t *) &desc;
+ int bad = 0;
+ size_t elem_len;
+
+ /* Initialize the descriptor to garbage values so we can confirm it's
+ properly initialized with good ones later. */
+ memset (a, -1, sizeof(desc));
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (a, ptr, attr, tc->typecode,
+ MAGIC_ELEM_LEN, 2, extents));
+
+ /* elem_len is ignored unless type is CFI type struct, CFI type other,
+ or a character type. */
+ if (tc->typecode == CFI_type_char
+ || tc->typecode == CFI_type_struct
+ || tc->typecode == CFI_type_other)
+ elem_len = MAGIC_ELEM_LEN;
+ else
+ elem_len = tc->size;
+
+ if (a->elem_len != elem_len
+ || a->base_addr != ptr
+ || a->type != tc->typecode
+ || a->version != CFI_VERSION
+ || a->attribute != attr
+ || a->rank != 2
+ || (ptr &&
+ /* extents parameter is ignored if ptr is null */
+ (a->dim[0].lower_bound != 0
+ || a->dim[0].extent != DIM0
+ || a->dim[0].sm != elem_len
+ || a->dim[1].lower_bound != 0
+ || a->dim[1].extent != DIM1
+ || a->dim[1].sm != elem_len*DIM0)))
+ {
+ fprintf (stderr, "Bad array descriptor for %s:\n", tc->name);
+ dump_CFI_cdesc_t (a);
+ return 1;
+ }
+ return 0;
+}
+
+/* External entry point. */
+extern void ctest_establish (void);
+
+void
+ctest_establish (void)
+{
+ int ncodes = sizeof (tc_table) / sizeof (struct tc_info);
+ int i;
+ int bad = 0;
+
+ for (i = 0; i < ncodes; i++)
+ {
+ bad += test_array (&tc_table[i], (void *)buf, CFI_attribute_other);
+ bad += test_array (&tc_table[i], NULL, CFI_attribute_allocatable);
+ bad += test_array (&tc_table[i], (void *)buf, CFI_attribute_pointer);
+ }
+ if (bad)
+ abort ();
+}
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/establish-errors-c.c b/gcc/testsuite/gfortran.dg/c-interop/establish-errors-c.c
new file mode 100644
index 00000000000..80976552db1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/establish-errors-c.c
@@ -0,0 +1,120 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+/* For simplicity, point descriptors at a static buffer. BUFSIZE should
+ be large enough for any of the standard types and we'll use DIM0 and DIM1
+ for array dimensions. */
+#define BUFSIZE 64
+#define DIM0 3
+#define DIM1 10
+#define ARRAYBUFSIZE BUFSIZE * DIM0 * DIM1
+static char *buf[ARRAYBUFSIZE] __attribute__ ((aligned (8)));
+static CFI_index_t extents[] = {DIM0, DIM1};
+
+/* Magic number to use for elem_len field. */
+#define MAGIC_ELEM_LEN 20
+
+
+/* External entry point. */
+extern void ctest (void);
+
+void
+ctest (void)
+{
+ int bad = 0;
+ int status;
+ CFI_CDESC_T(2) desc;
+ CFI_cdesc_t *a = (CFI_cdesc_t *) &desc;
+
+ /* If the attribute argument is CFI_attribute_allocatable,
+ base_addr shall be a null pointer. */
+ status = CFI_establish (a, (void *)buf, CFI_attribute_allocatable,
+ CFI_type_int, 0, 2, extents);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for non-null pointer with CFI_attribute_allocatable\n");
+ bad ++;
+ }
+
+ /* type shall have the value of one of the type codes in Table 18.4,
+ or have a positive value corresponding to an interoperable C type. */
+ status = CFI_establish (a, (void *)buf, CFI_attribute_other,
+ CFI_type_other - 1, 0, 2, extents);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for invalid negative type code\n");
+ bad ++;
+ }
+
+ /* If the type is CFI_type_struct, CFI_type_other, or a Fortran
+ character type, elem_len shall be greater than zero and equal to
+ the storage size in bytes of an element of the object. */
+ status = CFI_establish (a, (void *)buf, CFI_attribute_other,
+ CFI_type_struct, 0, 2, extents);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for invalid size with CFI_type_struct\n");
+ bad ++;
+ }
+
+ status = CFI_establish (a, (void *)buf, CFI_attribute_other,
+ CFI_type_char, 0, 2, extents);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for invalid size with CFI_type_char\n");
+ bad ++;
+ }
+
+ /* Rank shall be between 0 and CFI_MAX_RANK inclusive. */
+ status = CFI_establish (a, NULL, CFI_attribute_allocatable,
+ CFI_type_int, 0, -1, extents);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for negative rank\n");
+ bad ++;
+ }
+ status = CFI_establish (a, NULL, CFI_attribute_allocatable,
+ CFI_type_int, 0, CFI_MAX_RANK + 1, extents);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for rank > CFI_MAX_RANK\n");
+ bad ++;
+ }
+
+ /* extents is ignored if the rank r is zero or if base_addr is a
+ null pointer. Otherwise, it shall be the address of an array... */
+ status = CFI_establish (a, (void *)buf, CFI_attribute_other,
+ CFI_type_int, 0, 2, NULL);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for null extents\n");
+ bad ++;
+ }
+
+ /* Extents shall all be nonnegative. */
+ extents[1] = -extents[1];
+ status = CFI_establish (a, (void *)buf, CFI_attribute_other,
+ CFI_type_int, 0, 2, extents);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for negative extents\n");
+ bad ++;
+ }
+
+ if (bad)
+ abort ();
+}
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/establish-errors.f90 b/gcc/testsuite/gfortran.dg/c-interop/establish-errors.f90
new file mode 100644
index 00000000000..307a2664b74
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/establish-errors.f90
@@ -0,0 +1,30 @@
+! PR101317
+! { dg-do run }
+! { dg-additional-sources "establish-errors-c.c dump-descriptors.c" }
+! { dg-additional-options "-Wno-error -fcheck=all" }
+! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 }
+!
+! This program tests that the CFI_establish function properly detects
+! invalid arguments. All the interesting things happen in the
+! corresponding C code.
+!
+! The situation here seems to be that while TS29113 defines error codes
+! for CFI_establish, it doesn't actually require the implementation to detect
+! those errors by saying the arguments "shall be" such-and-such, e.g. it is
+! undefined behavior if they are not. In gfortran you can enable some
+! run-time checking by building with -fcheck=all.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+
+ subroutine ctest () bind (c)
+ end subroutine
+
+ end interface
+
+ call ctest ()
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/establish.f90 b/gcc/testsuite/gfortran.dg/c-interop/establish.f90
new file mode 100644
index 00000000000..5b263abf51f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/establish.f90
@@ -0,0 +1,35 @@
+! PR 101305
+! { dg-do run }
+! { dg-additional-sources "establish-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests the CFI_establish function. All the interesting
+! things happen in the corresponding C code.
+
+! Eventually we might want to make the C code pass the descriptors back to
+! C-callable Fortran functions, but for now it just checks them internally.
+
+module mm
+ use iso_c_binding
+
+ type, bind (c) :: s
+ integer(C_INT) :: i, j
+ end type
+end module
+
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+
+ subroutine ctest_establish () bind (c)
+ end subroutine
+
+ end interface
+
+ call ctest_establish ()
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/explicit-interface.f90 b/gcc/testsuite/gfortran.dg/c-interop/explicit-interface.f90
new file mode 100644
index 00000000000..a7eda825758
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/explicit-interface.f90
@@ -0,0 +1,60 @@
+! { dg-do compile }
+!
+! TS 29113
+! 6.2 Explicit interface
+!
+! Additionally to the rules of subclause 12.4.2.2 of ISO/IEC 1539-1:2010,
+! a procedure shall have an explicit interface if it has a dummy argument
+! that is assumed-rank.
+!
+! NOTE 6.1
+! An explicit interface is also required for a procedure if it has a
+! dummy argument that is assumed-type because an assumed-type dummy
+! argument is polymorphic.
+!
+! This file contains code that is expected to produce errors.
+
+module m1
+
+ interface
+
+ subroutine s1 (a)
+ integer :: a(..)
+ end subroutine
+
+ subroutine s2 (b)
+ type(*) :: b
+ end subroutine
+
+ end interface
+
+end module
+
+module m2
+
+ contains
+
+ ! This subroutine has an explicit interface, and so do the things
+ ! it calls.
+ subroutine good (a, b)
+ use m1
+ integer :: a(..)
+ type (*) :: b
+
+ call s1 (a)
+ call s2 (b)
+ end subroutine
+
+ ! This subroutine has an explicit interface, but the things it calls don't.
+ subroutine bad (a, b)
+ use m1
+ integer :: a(..)
+ type (*) :: b
+ external :: s3, s4
+
+ call s3 (a) ! { dg-error "Assumed-rank argument" }
+ call s4 (b) ! { dg-error "Assumed-type argument" }
+ end subroutine
+
+end module
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-1-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-1-c.c
new file mode 100644
index 00000000000..674f0bd6c4b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-1-c.c
@@ -0,0 +1,46 @@
+#include <stdlib.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a);
+
+void
+ctest (CFI_cdesc_t *a)
+{
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ /* The actual argument on the Fortran side was declared as
+ integer(C_INT) :: aa(10,-1:3)
+ Make sure that matches what's in the descriptor. Note that per
+ section 18.5.3 in the 2018 standard, for a nonallocatable nonpointer
+ array, the array dimensions in the descriptor reflect the shape of
+ the array rather than the actual bounds; the lower_bound is required
+ to be zero. */
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof(int))
+ abort ();
+ if (a->rank != 2)
+ abort ();
+ if (a->type != CFI_type_int)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ if (a->dim[0].extent != 10)
+ abort ();
+ if (a->dim[0].sm != sizeof(int))
+ abort ();
+ if (a->dim[1].lower_bound != 0)
+ abort ();
+ if (a->dim[1].extent != 5)
+ abort ();
+ if (a->dim[1].sm != a->dim[0].extent * sizeof(int))
+ abort ();
+ if (!CFI_is_contiguous (a))
+ abort ();
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-1.f90
new file mode 100644
index 00000000000..9a540eef021
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-1.f90
@@ -0,0 +1,34 @@
+! { dg-do run }
+! { dg-additional-sources "fc-descriptor-1-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This checks that a C function declared to have an assumed-shape array
+! argument can be called from Fortran and receives a correct descriptor.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest (a) bind (c)
+ use iso_c_binding
+ integer(C_INT) :: a(:,:)
+ end subroutine
+ end interface
+
+ integer(C_INT) :: aa(10,-1:3)
+
+ ! Test both passing the fixed-size array directly to the function
+ ! with a C interface, and indirectly via a Fortran function with an
+ ! assumed-shape dummy argument.
+ call ctest (aa)
+ call ftest (aa)
+
+contains
+ subroutine ftest (a)
+ use iso_c_binding
+ integer(C_INT) :: a(:,:)
+ call ctest (a)
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-2-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-2-c.c
new file mode 100644
index 00000000000..5ce0bfe91fe
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-2-c.c
@@ -0,0 +1,68 @@
+#include <stdlib.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a, int n);
+
+void
+ctest (CFI_cdesc_t *a, int n)
+{
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof(float))
+ abort ();
+ if (a->type != CFI_type_float)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+
+ if (n == 1)
+ {
+ /* The actual argument on the Fortran side was declared as
+ real(C_FLOAT):: aa(100) */
+ if (a->rank != 1)
+ abort ();
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ if (a->dim[0].extent != 100)
+ abort ();
+ if (a->dim[0].sm != sizeof(float))
+ abort ();
+ if (!CFI_is_contiguous (a))
+ abort ();
+ }
+ else if (n == 3)
+ {
+ /* The actual argument on the Fortran side was declared as
+ real(C_FLOAT) :: bb(3,4,5) */
+ if (a->rank != 3)
+ abort ();
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ if (a->dim[0].extent != 3)
+ abort ();
+ if (a->dim[0].sm != sizeof(float))
+ abort ();
+ if (a->dim[1].lower_bound != 0)
+ abort ();
+ if (a->dim[1].extent != 4)
+ abort ();
+ if (a->dim[1].sm != a->dim[0].sm * a->dim[0].extent)
+ abort ();
+ if (a->dim[2].lower_bound != 0)
+ abort ();
+ if (a->dim[2].extent != 5)
+ abort ();
+ if (a->dim[2].sm != a->dim[1].sm * a->dim[1].extent)
+ abort ();
+ if (!CFI_is_contiguous (a))
+ abort ();
+ }
+ else
+ abort ();
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-2.f90
new file mode 100644
index 00000000000..ec90735aaca
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-2.f90
@@ -0,0 +1,40 @@
+! { dg-do run }
+! { dg-additional-sources "fc-descriptor-2-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program checks that a C function declared to take an assumed-rank
+! array argument can be called from Fortran, and receives a correct
+! descriptor.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest (a, n) bind (c)
+ use iso_c_binding
+ real(C_FLOAT) :: a(..)
+ integer(C_INT), value :: n
+ end subroutine
+ end interface
+
+ real(C_FLOAT) :: aa(100)
+ real(C_FLOAT) :: bb(3,4,5)
+
+ ! Test both passing the fixed-size array directly to the function
+ ! with a C interface, and indirectly via a Fortran function with an
+ ! assumed-rank dummy argument.
+ call ctest (aa, 1)
+ call ctest (bb, 3)
+ call ftest (aa, 1)
+ call ftest (bb, 3)
+
+contains
+ subroutine ftest (a, n)
+ use iso_c_binding
+ real(C_FLOAT) :: a(..)
+ integer, value :: n
+ call ctest (a, n)
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3-c.c
new file mode 100644
index 00000000000..a432ee4c42c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3-c.c
@@ -0,0 +1,42 @@
+#include <stdlib.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp);
+
+void
+ctest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp)
+{
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+ dump_CFI_cdesc_t (b);
+
+ /* Make sure the descriptors match what we are expecting. a is an
+ allocatable derived type object, b is a pointer which points at a
+ if initp is true. */
+ if (initp && !a->base_addr)
+ abort ();
+ else if (!initp && a->base_addr)
+ abort ();
+ if (a->base_addr != b->base_addr)
+ abort ();
+
+ if (a->rank != 0)
+ abort ();
+ if (b->rank != 0)
+ abort ();
+ if (a->type != CFI_type_struct)
+ abort ();
+ if (b->type != CFI_type_struct)
+ abort ();
+ if (a->elem_len != 3 * 3 * sizeof(double))
+ abort ();
+ if (b->elem_len != 3 * 3 * sizeof(double))
+ abort ();
+ if (a->attribute != CFI_attribute_allocatable)
+ abort ();
+ if (b->attribute != CFI_attribute_pointer)
+ abort ();
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3.f90
new file mode 100644
index 00000000000..174d1e728fd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3.f90
@@ -0,0 +1,37 @@
+! PR 101308
+! { dg-do run { xfail *-*-* } }
+! { dg-additional-sources "fc-descriptor-3-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests that pointer and allocatable scalar arguments are
+! correctly passed by descriptor from Fortran code into C.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ type, bind (c) :: m
+ real(C_DOUBLE) :: a(3, 3)
+ end type
+
+ interface
+ subroutine ctest (a, b, initp) bind (c)
+ use iso_c_binding
+ import m
+ type(m), allocatable :: a
+ type(m), pointer :: b
+ integer(C_INT), value :: initp
+ end subroutine
+ end interface
+
+ type (m), allocatable, target :: aa
+ type (m), pointer :: bb
+
+ ! Test both before and after allocation/pointer initialization.
+ bb => null()
+ call ctest (aa, bb, 0)
+ allocate (aa)
+ bb => aa
+ call ctest (aa, bb, 1)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-4-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-4-c.c
new file mode 100644
index 00000000000..579e66d9376
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-4-c.c
@@ -0,0 +1,57 @@
+#include <stdlib.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp);
+
+void
+ctest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp)
+{
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+ dump_CFI_cdesc_t (b);
+
+ /* Make sure the descriptors match what we are expecting. a is an
+ allocatable derived type object, b is a pointer which points at a
+ if initp is true. */
+ if (initp && !a->base_addr)
+ abort ();
+ else if (!initp && a->base_addr)
+ abort ();
+ if (a->base_addr != b->base_addr)
+ abort ();
+
+ if (a->type != CFI_type_struct)
+ abort ();
+ if (b->type != CFI_type_struct)
+ abort ();
+ if (a->elem_len != 3 * 3 * sizeof(double))
+ abort ();
+ if (b->elem_len != 3 * 3 * sizeof(double))
+ abort ();
+ if (a->attribute != CFI_attribute_allocatable)
+ abort ();
+ if (b->attribute != CFI_attribute_pointer)
+ abort ();
+
+ if (initp)
+ /* The actual array is allocated with
+ allocate (aa(3:7))
+ Per 8.3.3 of TS29113, the lower_bound must reflect that. */
+ {
+ if (a->rank != 1)
+ abort ();
+ if (b->rank != 1)
+ abort ();
+ if (a->dim[0].lower_bound != 3)
+ abort ();
+ if (b->dim[0].lower_bound != 3)
+ abort ();
+ if (a->dim[0].extent != 5)
+ abort ();
+ if (b->dim[0].extent != 5)
+ abort ();
+ }
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-4.f90
new file mode 100644
index 00000000000..db73dafe1d5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-4.f90
@@ -0,0 +1,36 @@
+! { dg-do run }
+! { dg-additional-sources "fc-descriptor-4-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests that pointer and allocatable array arguments are
+! correctly passed by descriptor from Fortran code into C.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ type, bind (c) :: m
+ real(C_DOUBLE) :: a(3, 3)
+ end type
+
+ interface
+ subroutine ctest (a, b, initp) bind (c)
+ use iso_c_binding
+ import m
+ type(m), allocatable :: a(:)
+ type(m), pointer :: b(:)
+ integer(C_INT), value :: initp
+ end subroutine
+ end interface
+
+ type (m), allocatable, target :: aa(:)
+ type (m), pointer :: bb(:)
+
+ ! Test both before and after allocation/pointer initialization.
+ bb => NULL ()
+ call ctest (aa, bb, 0)
+ allocate (aa(3:7))
+ bb => aa
+ call ctest (aa, bb, 1)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5-c.c
new file mode 100644
index 00000000000..6f2718501d2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5-c.c
@@ -0,0 +1,28 @@
+#include <stdlib.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a);
+
+void
+ctest (CFI_cdesc_t *a)
+{
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ /* The actual argument on the Fortran side was declared as
+ character(len=20) :: aa
+ Make sure that matches what's in the descriptor. */
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != 20)
+ abort ();
+ if (a->rank != 0)
+ abort ();
+ if (a->type != CFI_type_char)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5.f90
new file mode 100644
index 00000000000..5ac406fdcc1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5.f90
@@ -0,0 +1,35 @@
+! PR92482
+! { dg-do run }
+! { dg-additional-sources "fc-descriptor-5-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests it works to call a C function from Fortran with
+! an assumed length character dummy.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ use iso_c_binding
+ character(len=*,kind=C_CHAR) :: a
+ end subroutine
+ end interface
+
+ character(len=20,kind=C_CHAR) :: aa
+
+ ! Test both passing the fixed-length string directly to the function
+ ! with a C interface, and indirectly via a Fortran function with an
+ ! assumed-length dummy argument.
+ call ctest (aa)
+ call ftest (aa)
+
+contains
+ subroutine ftest (a)
+ use iso_c_binding
+ character(len=*,kind=C_CHAR) :: a
+ call ctest (a)
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6-c.c
new file mode 100644
index 00000000000..875dbb87930
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6-c.c
@@ -0,0 +1,51 @@
+#include <stdlib.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a);
+
+void
+ctest (CFI_cdesc_t *a)
+{
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ /* The actual argument on the Fortran side was declared as
+ integer(C_INT) :: aa(10,5:8)
+ but was passed via other functions that variously describe it as
+ having size (10,*), (10,1:*), or (10,5:*). But, the spec says:
+
+ For a C descriptor of a nonallocatable nonpointer object, the
+ value of the lower_bound member of each element of the dim member
+ of the descriptor is zero.
+
+ In a C descriptor of an assumed-size array, the extent member of
+ the last element of the dim member has the value −1. */
+
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof(int))
+ abort ();
+ if (a->rank != 2)
+ abort ();
+ if (a->type != CFI_type_int)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ if (a->dim[0].extent != 10)
+ abort ();
+ if (a->dim[0].sm != sizeof(int))
+ abort ();
+ if (a->dim[1].lower_bound != 0)
+ abort ();
+ if (a->dim[1].extent != -1)
+ abort ();
+ if (a->dim[1].sm != a->dim[0].extent * sizeof(int))
+ abort ();
+}
+
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6.f90
new file mode 100644
index 00000000000..8c544d18402
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6.f90
@@ -0,0 +1,50 @@
+! Reported as pr94070.
+! { dg-do run { xfail *-*-* } }
+! { dg-additional-sources "fc-descriptor-6-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program checks that an assumed-size array argument can be passed
+! to a C function via a descriptor, and that the argument descriptor
+! received by C correctly identifies it as assumed-size.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ ! Assumed-size arrays are not passed by descriptor. What we'll do
+ ! for this test function is bind an assumed-rank dummy
+ ! to the assumed-size array. This is supposed to fill in the descriptor
+ ! with information about the array present at the call site.
+ interface
+ subroutine ctest (a) bind (c)
+ use iso_c_binding
+ integer(C_INT) :: a(..)
+ end subroutine
+ end interface
+
+ integer(C_INT), target :: aa(10,5:8)
+
+ ! To get an assumed-size array descriptor, we have to first pass the
+ ! fixed-size array to a Fortran function with an assumed-size dummy,
+ call ftest1 (aa)
+ call ftest2 (aa)
+ call ftest3 (aa)
+
+contains
+ subroutine ftest1 (a)
+ use iso_c_binding
+ integer(C_INT) :: a(10,*)
+ call ctest (a)
+ end subroutine
+ subroutine ftest2 (a)
+ use iso_c_binding
+ integer(C_INT) :: a(10,5:*)
+ call ctest (a)
+ end subroutine
+ subroutine ftest3 (a)
+ use iso_c_binding
+ integer(C_INT) :: a(10,1:*)
+ call ctest (a)
+ end subroutine
+
+end program
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
new file mode 100644
index 00000000000..81d826f276f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7-c.c
@@ -0,0 +1,46 @@
+#include <stdlib.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a);
+
+void
+ctest (CFI_cdesc_t *a)
+{
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ /* We expect to get an array of shape (5,10) that may not be
+ contiguous. */
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof(int))
+ abort ();
+ if (a->rank != 2)
+ abort ();
+ if (a->type != CFI_type_int)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ if (a->dim[0].extent != 5)
+ abort ();
+ if (a->dim[1].lower_bound != 0)
+ abort ();
+ 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)
+ abort ();
+ if (abs (a->dim[1].sm) < abs (a->dim[0].sm) * a->dim[0].extent)
+ 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
new file mode 100644
index 00000000000..5be72e7e01c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7.f90
@@ -0,0 +1,37 @@
+! PR 101309
+! { dg-do run { xfail *-*-* } }
+! { dg-additional-sources "fc-descriptor-7-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests passing arrays that may not be contiguous through
+! descriptors to C functions as assumed-shape arguments.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest (a) bind (c)
+ use iso_c_binding
+ integer(C_INT), intent (in) :: a(:,:)
+ end subroutine
+ end interface
+
+ integer(C_INT), target :: aa(10,5)
+ integer(C_INT), target :: bb(10,10)
+
+ ! 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, :))
+
+contains
+ subroutine ftest (a)
+ use iso_c_binding
+ integer(C_INT), intent(in) :: a(:,:)
+ call ctest (a)
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-8-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-8-c.c
new file mode 100644
index 00000000000..8adf8e31036
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-8-c.c
@@ -0,0 +1,20 @@
+/* TS29113 8.3.1: ISO_Fortran_binding.h may be included more than once. */
+
+#include <stdlib.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+#include <ISO_Fortran_binding.h>
+
+extern void ctest (CFI_cdesc_t *a);
+
+void
+ctest (CFI_cdesc_t *a)
+{
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ if (a->version != CFI_VERSION)
+ abort ();
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-8.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-8.f90
new file mode 100644
index 00000000000..42345ad945c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-8.f90
@@ -0,0 +1,22 @@
+! { dg-do run }
+! { dg-additional-sources "fc-descriptor-8-c.c dump-descriptors.c" }
+!
+! Check that C descriptors have the version field set correctly.
+! This program is just a stub to create a descriptor and pass it to the
+! C function, which does the actual test.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest (a) bind (c)
+ use iso_c_binding
+ integer(C_INT) :: a(:,:)
+ end subroutine
+ end interface
+
+ integer(C_INT) :: aa(10,-1:3)
+ call ctest (aa)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-9-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-9-c.c
new file mode 100644
index 00000000000..05e6581eeb8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-9-c.c
@@ -0,0 +1,42 @@
+/* 8.3.1: ISO_Fortran_binding.h may be included more than once. */
+
+#include <stdlib.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a);
+
+struct descriptor_fixed_part {
+ void *base_addr;
+ size_t elem_len;
+ int version;
+};
+
+void
+ctest (CFI_cdesc_t *a)
+{
+ struct descriptor_fixed_part *f = (struct descriptor_fixed_part *) a;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ /* The first three members of the structure shall be base_addr,
+ elem_len, and version in that order. */
+ if (&(a->base_addr) != &(f->base_addr))
+ abort ();
+ if (&(a->elem_len) != &(f->elem_len))
+ abort ();
+ if (&(a->version) != &(f->version))
+ abort ();
+
+ /* The final member shall be dim, with the other members after version
+ and before dim in any order. */
+ if ((void *)&(a->rank) >= (void *)a->dim)
+ abort ();
+ if ((void *)&(a->type) >= (void *)a->dim)
+ abort ();
+ if ((void *)&(a->attribute) >= (void *)a->dim)
+ abort ();
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-9.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-9.f90
new file mode 100644
index 00000000000..e54f677ec75
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-9.f90
@@ -0,0 +1,23 @@
+! { dg-do run }
+! { dg-additional-sources "fc-descriptor-9-c.c dump-descriptors.c" }
+!
+! Check that C descriptors follow the layout restrictions described in
+! section 8.3.3 of TS29113.
+! This program is just a stub to create a descriptor and pass it to the
+! C function, which does the actual test.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest (a) bind (c)
+ use iso_c_binding
+ integer(C_INT) :: a(:,:)
+ end subroutine
+ end interface
+
+ integer(C_INT) :: aa(10,-1:3)
+ call ctest (aa)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-1-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-1-c.c
new file mode 100644
index 00000000000..18b37e193cb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-1-c.c
@@ -0,0 +1,52 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (int imax, int jmax, CFI_cdesc_t *a);
+
+struct m {
+ int i;
+ int j;
+};
+
+void
+ctest (int imax, int jmax, CFI_cdesc_t *a)
+{
+
+ int i, j;
+ CFI_index_t subscripts[2];
+ struct m* mp;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ if (a->rank != 2)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ if (a->dim[0].extent != imax)
+ abort ();
+ if (a->dim[1].lower_bound != 0)
+ abort ();
+ if (a->dim[1].extent != jmax)
+ abort ();
+
+ /* Fill in the contents of a. a is zero-based but we want the ->i and ->j
+ members of each element to be numbered starting from 1. */
+ for (j = 0; j < jmax; j++)
+ {
+ subscripts[1] = j;
+ for (i = 0; i < imax; i++)
+ {
+ subscripts[0] = i;
+ mp = (struct m *) CFI_address (a, subscripts);
+ mp->i = i + 1;
+ mp->j = j + 1;
+ }
+ }
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-1.f90
new file mode 100644
index 00000000000..d0c30b5591d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-1.f90
@@ -0,0 +1,66 @@
+! { dg-do run }
+! { dg-additional-sources "fc-out-descriptor-1-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program checks that passing a fixed-size array as an intent(out)
+! assumed-shape argument to a C function called from Fortran works.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer, parameter :: imax=10, jmax=5
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest (ii, jj, a) bind (c)
+ use iso_c_binding
+ use mm
+ integer(C_INT), value :: ii, jj
+ type(m), intent(out) :: a(:,:)
+ end subroutine
+ end interface
+
+ type(m) :: aa(imax,jmax)
+ integer :: i, j
+
+ ! initialize the array to all zeros; ctest will overwrite it.
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = 0
+ aa(i,j)%j = 0
+ end do
+ end do
+
+ call ctest (imax, jmax, aa)
+ call verify (aa)
+
+contains
+subroutine verify (a)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ integer :: i, j
+
+ if (rank (a) .ne. 2) stop 100
+ if (lbound (a, 1) .ne. 1) stop 101
+ if (lbound (a, 2) .ne. 1) stop 102
+ if (ubound (a, 1) .ne. imax) stop 103
+ if (ubound (a, 2) .ne. jmax) stop 104
+
+ do j = 1, jmax
+ do i = 1, imax
+ if (a(i,j)%i .ne. i) stop 201
+ if (a(i,j)%j .ne. j) stop 202
+ end do
+ end do
+end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-2-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-2-c.c
new file mode 100644
index 00000000000..18b37e193cb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-2-c.c
@@ -0,0 +1,52 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (int imax, int jmax, CFI_cdesc_t *a);
+
+struct m {
+ int i;
+ int j;
+};
+
+void
+ctest (int imax, int jmax, CFI_cdesc_t *a)
+{
+
+ int i, j;
+ CFI_index_t subscripts[2];
+ struct m* mp;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ if (a->rank != 2)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ if (a->dim[0].extent != imax)
+ abort ();
+ if (a->dim[1].lower_bound != 0)
+ abort ();
+ if (a->dim[1].extent != jmax)
+ abort ();
+
+ /* Fill in the contents of a. a is zero-based but we want the ->i and ->j
+ members of each element to be numbered starting from 1. */
+ for (j = 0; j < jmax; j++)
+ {
+ subscripts[1] = j;
+ for (i = 0; i < imax; i++)
+ {
+ subscripts[0] = i;
+ mp = (struct m *) CFI_address (a, subscripts);
+ mp->i = i + 1;
+ mp->j = j + 1;
+ }
+ }
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-2.f90
new file mode 100644
index 00000000000..87cfb6ecbd8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-2.f90
@@ -0,0 +1,66 @@
+! { dg-do run }
+! { dg-additional-sources "fc-out-descriptor-2-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program checks that passing a fixed-size array as an intent(out)
+! assumed-rank argument to a C function called from Fortran works.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer, parameter :: imax=10, jmax=5
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest (ii, jj, a) bind (c)
+ use iso_c_binding
+ use mm
+ integer(C_INT), value :: ii, jj
+ type(m), intent(out) :: a(..)
+ end subroutine
+ end interface
+
+ type(m) :: aa(imax,jmax)
+ integer :: i, j
+
+ ! initialize the array to all zeros; ctest will overwrite it.
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = 0
+ aa(i,j)%j = 0
+ end do
+ end do
+
+ call ctest (imax, jmax, aa)
+ call verify (aa)
+
+contains
+subroutine verify (a)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ integer :: i, j
+
+ if (rank (a) .ne. 2) stop 100
+ if (lbound (a, 1) .ne. 1) stop 101
+ if (lbound (a, 2) .ne. 1) stop 102
+ if (ubound (a, 1) .ne. imax) stop 103
+ if (ubound (a, 2) .ne. jmax) stop 104
+
+ do j = 1, jmax
+ do i = 1, imax
+ if (a(i,j)%i .ne. i) stop 201
+ if (a(i,j)%j .ne. j) stop 202
+ end do
+ end do
+end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-3-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-3-c.c
new file mode 100644
index 00000000000..7de226e107c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-3-c.c
@@ -0,0 +1,71 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest1 (int iinit, int jinit, CFI_cdesc_t *p);
+extern void ctest2 (int iinit, int jinit, CFI_cdesc_t *a);
+
+struct m {
+ int i;
+ int j;
+};
+
+void
+ctest1 (int iinit, int jinit, CFI_cdesc_t *p)
+{
+ struct m *mp;
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (p);
+
+ if (p->rank != 0)
+ abort ();
+ if (p->attribute != CFI_attribute_pointer)
+ abort ();
+ if (p->type != CFI_type_struct)
+ abort ();
+
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (p, NULL, NULL, sizeof (struct m)));
+
+ if (p->base_addr == NULL)
+ abort ();
+
+ mp = (struct m *) CFI_address (p, NULL);
+ mp->i = iinit;
+ mp->j = jinit;
+}
+
+
+void
+ctest2 (int iinit, int jinit, CFI_cdesc_t *a)
+{
+ struct m *mp;
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ if (a->rank != 0)
+ abort ();
+ if (a->attribute != CFI_attribute_allocatable)
+ abort ();
+ if (a->type != CFI_type_struct)
+ abort ();
+
+ /* The intent(out) allocatable array is supposed to be deallocated
+ automatically on entry, if it was previously allocated. */
+ if (a->base_addr)
+ abort ();
+
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (a, NULL, NULL, sizeof (struct m)));
+
+ if (a->base_addr == NULL)
+ abort ();
+
+ mp = (struct m *) CFI_address (a, NULL);
+ mp->i = iinit;
+ mp->j = jinit;
+}
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
new file mode 100644
index 00000000000..c555ada7996
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-3.f90
@@ -0,0 +1,59 @@
+! PR 101308
+! { dg-do run { xfail *-*-* } }
+! { dg-additional-sources "fc-out-descriptor-3-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program checks that passing an allocatable or pointer scalar
+! as an intent(out) argument to a C function called from Fortran works.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer(C_INT), parameter :: iinit = 42, jinit = 12345
+
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest1 (ii, jj, p) bind (c)
+ use iso_c_binding
+ use mm
+ integer(C_INT), value :: ii, jj
+ type(m), intent(out), pointer :: p
+ end subroutine
+ subroutine ctest2 (ii, jj, a) bind (c)
+ use iso_c_binding
+ use mm
+ integer(C_INT), value :: ii, jj
+ type(m), intent(out), allocatable :: a
+ end subroutine
+ end interface
+
+ type(m), pointer :: p
+ type(m), allocatable :: a
+
+ ! The association status of the intent(out) pointer argument is supposed
+ ! to become undefined on entry to the called procedure.
+ p => NULL ()
+ call ctest1 (iinit, jinit, p)
+ if (.not. associated (p)) stop 101
+ if (p%i .ne. iinit) stop 102
+ if (p%j .ne. jinit) stop 103
+
+ ! The intent(out) argument is supposed to be deallocated automatically
+ ! on entry to the called function.
+ allocate (a)
+ a%i = 0
+ a%j = 0
+ call ctest2 (iinit, jinit, a)
+ if (.not. allocated (a)) stop 201
+ if (a%i .ne. iinit) stop 202
+ if (a%j .ne. jinit) stop 203
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-4-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-4-c.c
new file mode 100644
index 00000000000..6e1324b56d1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-4-c.c
@@ -0,0 +1,96 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest1 (int imin, int imax, int jmin, int jmax, CFI_cdesc_t *p);
+extern void ctest2 (int imin, int imax, int jmin, int jmax, CFI_cdesc_t *a);
+
+struct m {
+ int i;
+ int j;
+};
+
+void
+ctest1 (int imin, int imax, int jmin, int jmax, CFI_cdesc_t *p)
+{
+ struct m *mp;
+ int i, j;
+ CFI_index_t lb[2], ub[2], s[2];
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (p);
+
+ if (p->rank != 2)
+ abort ();
+ if (p->attribute != CFI_attribute_pointer)
+ abort ();
+ if (p->type != CFI_type_struct)
+ abort ();
+
+ lb[0] = imin;
+ lb[1] = jmin;
+ ub[0] = imax;
+ ub[1] = jmax;
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (p, lb, ub, sizeof (struct m)));
+
+ if (p->base_addr == NULL)
+ abort ();
+
+ for (j = jmin; j <= jmax; j++)
+ for (i = imin; i <= imax; i++)
+ {
+ s[0] = i;
+ s[1] = j;
+ mp = (struct m *) CFI_address (p, s);
+ mp->i = i;
+ mp->j = j;
+ }
+}
+
+void
+ctest2 (int imin, int imax, int jmin, int jmax, CFI_cdesc_t *a)
+{
+ struct m *mp;
+ int i, j;
+ CFI_index_t lb[2], ub[2], s[2];
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ if (a->rank != 2)
+ abort ();
+ if (a->attribute != CFI_attribute_allocatable)
+ abort ();
+ if (a->type != CFI_type_struct)
+ abort ();
+
+ /* Intent(out) argument is supposed to be deallocated automatically
+ on entry. */
+ if (a->base_addr)
+ abort ();
+
+ lb[0] = imin;
+ lb[1] = jmin;
+ ub[0] = imax;
+ ub[1] = jmax;
+ check_CFI_status ("CFI_allocate",
+ CFI_allocate (a, lb, ub, sizeof (struct m)));
+
+ if (a->base_addr == NULL)
+ abort ();
+
+ for (j = jmin; j <= jmax; j++)
+ for (i = imin; i <= imax; i++)
+ {
+ s[0] = i;
+ s[1] = j;
+ mp = (struct m *) CFI_address (a, s);
+ mp->i = i;
+ mp->j = j;
+ }
+}
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
new file mode 100644
index 00000000000..b4f6654c2e1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-4.f90
@@ -0,0 +1,75 @@
+! PR 92621 (?)
+! { dg-do run { xfail *-*-* } }
+! { dg-additional-sources "fc-out-descriptor-4-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program checks that passing an allocatable or pointer array
+! as an intent(out) argument to a C function called from Fortran works.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer(C_INT), parameter :: imin = 5, imax = 10, jmin = -10, jmax = -1
+
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest1 (i0, ii, j0, jj, p) bind (c)
+ use iso_c_binding
+ use mm
+ integer(C_INT), value :: i0, ii, j0, jj
+ type(m), intent(out), pointer :: p(:,:)
+ end subroutine
+ subroutine ctest2 (i0, ii, j0, jj, a) bind (c)
+ use iso_c_binding
+ use mm
+ integer(C_INT), value :: i0, ii, j0, jj
+ type(m), intent(out), allocatable :: a(:,:)
+ end subroutine
+ end interface
+
+ type(m), pointer :: p(:,:)
+ type(m), allocatable :: a(:,:)
+ integer :: i, j
+
+ p => NULL ()
+ call ctest1 (imin, imax, jmin, jmax, p)
+ if (.not. associated (p)) stop 101
+ if (rank(p) .ne. 2) stop 102
+ if (lbound (p, 1) .ne. imin) stop 103
+ if (ubound (p, 1) .ne. imax) stop 104
+ if (lbound (p, 2) .ne. jmin) stop 105
+ if (ubound (p, 2) .ne. jmax) stop 106
+ do j = jmin, jmax
+ do i = imin, imax
+ if (p(i,j)%i .ne. i) stop 107
+ if (p(i,j)%j .ne. j) stop 108
+ end do
+ end do
+
+ ! The intent(out) argument is supposed to be deallocated automatically
+ ! on entry to the called function.
+ allocate (a (jmin:jmax,imin:imax))
+ if (.not. allocated (a)) stop 201
+ call ctest2 (imin, imax, jmin, jmax, a)
+ if (.not. allocated (a)) stop 201
+ if (rank(a) .ne. 2) stop 202
+ if (lbound (a, 1) .ne. imin) stop 203
+ if (ubound (a, 1) .ne. imax) stop 204
+ if (lbound (a, 2) .ne. jmin) stop 205
+ if (ubound (a, 2) .ne. jmax) stop 206
+ do j = jmin, jmax
+ do i = imin, imax
+ if (a(i,j)%i .ne. i) stop 207
+ if (a(i,j)%j .ne. j) stop 208
+ end do
+ end do
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-5-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-5-c.c
new file mode 100644
index 00000000000..337bc22d1f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-5-c.c
@@ -0,0 +1,30 @@
+#include <stdlib.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a);
+
+void
+ctest (CFI_cdesc_t *a)
+{
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ /* The character object passed as the argument was declared on the
+ Fortran side as character(len=26) :: aa
+ Make sure that matches what's in the descriptor. */
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != 26)
+ abort ();
+ if (a->rank != 0)
+ abort ();
+ if (a->type != CFI_type_char)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ strncpy ((char *)a->base_addr, "0123456789", 10);
+}
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
new file mode 100644
index 00000000000..836683bd971
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-5.f90
@@ -0,0 +1,35 @@
+! PR92482
+! { dg-do run }
+! { dg-additional-sources "fc-out-descriptor-5-c.c dump-descriptors.c" }
+!
+! This program checks that you can call a C function declared with an
+! assumed-length character dummy from Fortran.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ use iso_c_binding
+ character(len=*,kind=C_CHAR), intent(out) :: a
+ end subroutine
+ end interface
+
+ character(len=26,kind=C_CHAR) :: aa
+ aa = 'abcdefghijklmnopqrstuvwxyz'
+
+ ! Test both passing the fixed-length-string directly to the function
+ ! with a C interface, and indirectly via a Fortran function with an
+ ! assumed-length dummy argument.
+ call ctest (aa)
+ call ftest (aa)
+
+contains
+ subroutine ftest (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ use iso_c_binding
+ character(len=*,kind=C_CHAR), intent(out) :: a
+ call ctest (a)
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-6-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-6-c.c
new file mode 100644
index 00000000000..2711a98aa0a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-6-c.c
@@ -0,0 +1,50 @@
+#include <stdlib.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a);
+
+void
+ctest (CFI_cdesc_t *a)
+{
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ dump_CFI_cdesc_t (a);
+
+ /* The actual argument on the Fortran side was declared as
+ integer(C_INT) :: aa(10,5:8)
+ but was passed via other functions that variously describe it as
+ having size (10,*), (10,1:*), or (10,5:*) before calling this function
+ with an assumed-rank array dummy. But, the spec says:
+
+ For a C descriptor of a nonallocatable nonpointer object, the
+ value of the lower_bound member of each element of the dim member
+ of the descriptor is zero.
+
+ In a C descriptor of an assumed-size array, the extent member of
+ the last element of the dim member has the value −1. */
+
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof(int))
+ abort ();
+ if (a->rank != 2)
+ abort ();
+ if (a->type != CFI_type_int)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ if (a->dim[0].extent != 10)
+ abort ();
+ if (a->dim[0].sm != sizeof(int))
+ abort ();
+ if (a->dim[1].lower_bound != 0)
+ abort ();
+ if (a->dim[1].extent != -1)
+ abort ();
+ if (a->dim[1].sm != a->dim[0].extent * sizeof(int))
+ abort ();
+}
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
new file mode 100644
index 00000000000..d0c3904e27e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-6.f90
@@ -0,0 +1,49 @@
+! Reported as pr94070.
+! { dg-do run { xfail *-*-* } }
+! { dg-additional-sources "fc-out-descriptor-6-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program checks passing an assumed-size array argument via descriptor
+! from Fortran to C.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ ! Assumed-size arrays are not passed by descriptor. What we'll do
+ ! for this test function is bind an assumed-rank dummy to an
+ ! assumed-size array. This is supposed to fill in the descriptor
+ ! with information about the array present at the call site.
+ interface
+ subroutine ctest (a) bind (c)
+ use iso_c_binding
+ integer(C_INT), intent(out) :: a(..)
+ end subroutine
+ end interface
+
+ integer(C_INT), target :: aa(10,5:8)
+
+ ! To get an assumed-size array descriptor, we have to first pass the
+ ! fixed-size array to a Fortran function with an assumed-size dummy.
+ call ftest1 (aa)
+ call ftest2 (aa)
+ call ftest3 (aa)
+
+contains
+ subroutine ftest1 (a)
+ use iso_c_binding
+ integer(C_INT) :: a(10,*)
+ call ctest (a)
+ end subroutine
+ subroutine ftest2 (a)
+ use iso_c_binding
+ integer(C_INT) :: a(10,5:*)
+ call ctest (a)
+ end subroutine
+ subroutine ftest3 (a)
+ use iso_c_binding
+ integer(C_INT) :: a(10,1:*)
+ call ctest (a)
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-7-c.c b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-7-c.c
new file mode 100644
index 00000000000..be9fc928bed
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-7-c.c
@@ -0,0 +1,136 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+struct m {
+ int i;
+ int j;
+};
+
+extern void ctest (CFI_cdesc_t *a, int lb1, int ub1, int s1,
+ int lb2, int ub2, int s2, CFI_cdesc_t *b);
+
+/* Check array b against the section of array a defined by the given
+ bounds. */
+static void
+check_array (CFI_cdesc_t *a, CFI_cdesc_t *b,
+ int lb1, int ub1, int s1, int lb2, int ub2, int s2)
+{
+ int bad = 0;
+ int i, ii, j, jj;
+ CFI_index_t sub[2];
+ struct m *ap, *bp;
+
+ for (j = lb2, jj = b->dim[1].lower_bound; j <= ub2; jj++, j += s2)
+ for (i = lb1, ii = b->dim[0].lower_bound; i <= ub1; ii++, i += s1)
+ {
+ sub[0] = i;
+ sub[1] = j;
+ ap = (struct m *) CFI_address (a, sub);
+ sub[0] = ii;
+ sub[1] = jj;
+ bp = (struct m *) CFI_address (b, sub);
+#if 0
+ fprintf (stderr, "b(%d,%d) = (%d,%d) expecting (%d,%d)\n",
+ ii, jj, bp->i, bp->j, ap->i, ap->j);
+#endif
+ if (ap->i != bp->i || ap->j != bp->j)
+ bad = 1;
+ }
+ if (bad)
+ abort ();
+}
+
+void
+ctest (CFI_cdesc_t *a, int lb1, int ub1, int s1,
+ int lb2, int ub2, int s2, CFI_cdesc_t *b)
+{
+ CFI_index_t lb[2], ub[2], s[2];
+ CFI_index_t i, j;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ fprintf (stderr, "input arrays\n");
+ dump_CFI_cdesc_t (a);
+ dump_CFI_cdesc_t (b);
+
+ /* We expect to get a zero-based input array of shape (10,5). */
+ if (a->rank != 2)
+ abort ();
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->type != CFI_type_struct)
+ abort ();
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ if (a->dim[0].extent != 10)
+ abort ();
+ if (a->dim[1].lower_bound != 0)
+ abort ();
+ if (a->dim[1].extent != 5)
+ abort ();
+
+ /* The output descriptor has to agree with the input descriptor. */
+ if (b->rank != 2)
+ abort ();
+ if (b->attribute != CFI_attribute_pointer)
+ abort ();
+ if (b->type != CFI_type_struct)
+ abort ();
+ if (b->elem_len != a->elem_len)
+ abort ();
+
+ /* Point b at a, keeping the 0-based bounds. */
+ check_CFI_status ("CFI_setpointer",
+ CFI_setpointer (b, a, NULL));
+ fprintf (stderr, "After initializing b\n");
+ dump_CFI_cdesc_t (b);
+ if (b->dim[0].lower_bound != 0)
+ abort ();
+ if (b->dim[1].lower_bound != 0)
+ abort ();
+ check_array (a, b,
+ a->dim[0].lower_bound,
+ a->dim[0].lower_bound + a->dim[0].extent - 1,
+ 1,
+ a->dim[1].lower_bound,
+ a->dim[1].lower_bound + a->dim[1].extent - 1,
+ 1);
+
+ /* Take a section of the array. The bounds passed in to this function
+ assume the array is 1-based in both dimensions, so subtract 1. */
+ lb[0] = b->dim[0].lower_bound + lb1 - 1;
+ lb[1] = b->dim[1].lower_bound + lb2 - 1;
+ ub[0] = b->dim[0].lower_bound + ub1 - 1;
+ ub[1] = b->dim[1].lower_bound + ub2 - 1;
+ s[0] = s1;
+ s[1] = s2;
+ check_CFI_status ("CFI_section",
+ CFI_section (b, b, lb, ub, s));
+ fprintf (stderr, "After CFI_section\n");
+ dump_CFI_cdesc_t (b);
+ check_array (a, b,
+ a->dim[0].lower_bound + lb1 - 1,
+ a->dim[0].lower_bound + ub1 - 1,
+ s1,
+ a->dim[1].lower_bound + lb2 - 1,
+ a->dim[1].lower_bound + ub2 - 1,
+ s2);
+
+ /* Adjust b to be 1-based. */
+ lb[0] = 1;
+ lb[1] = 1;
+ fprintf (stderr, "After rebasing b again\n");
+ check_CFI_status ("CFI_setpointer",
+ CFI_setpointer (b, b, lb));
+ dump_CFI_cdesc_t (b);
+ check_array (a, b,
+ a->dim[0].lower_bound + lb1 - 1,
+ a->dim[0].lower_bound + ub1 - 1,
+ s1,
+ a->dim[1].lower_bound + lb2 - 1,
+ a->dim[1].lower_bound + ub2 - 1,
+ s2);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-7.f90 b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-7.f90
new file mode 100644
index 00000000000..209f96f51ea
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-7.f90
@@ -0,0 +1,71 @@
+! PR 101310
+! { dg-do run }
+! { dg-additional-sources "fc-out-descriptor-7-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program checks that returning a noncontiguous array as an intent(out)
+! argument to a C function called from Fortran works.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer(C_INT), parameter :: imax = 10, jmax=5
+
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ ! ctest points b at a section of array a defined by the
+ ! indicated bounds and steps. The returned array is 1-based.
+ subroutine ctest (a, lb1, ub1, s1, lb2, ub2, s2, b) bind (c)
+ use iso_c_binding
+ use mm
+ type(m), target :: a(:,:)
+ integer(C_INT), value :: lb1, ub1, s1, lb2, ub2, s2
+ type(m), intent(out), pointer :: b(:,:)
+ end subroutine
+ end interface
+
+ type(m), target :: a(imax, jmax)
+ type(m), pointer :: b(:,:)
+ integer :: i, j, ii, jj
+
+ do j = 1, jmax
+ do i = 1, imax
+ a(i,j)%i = i
+ a(i,j)%j = j
+ end do
+ end do
+
+ b => NULL ()
+ ! resulting array is 1-based and has shape (3,3)
+ call ctest (a, 2, 8, 3, 1, 5, 2, b)
+ if (.not. associated (b)) stop 101
+ if (rank(b) .ne. 2) stop 102
+ if (lbound (b, 1) .ne. 1) stop 103
+ if (ubound (b, 1) .ne. 3) stop 104
+ if (lbound (b, 2) .ne. 1) stop 105
+ if (ubound (b, 2) .ne. 3) stop 106
+
+ ! check that the returned array b contains the expected elements
+ ! from array a.
+ jj = lbound (b, 2)
+ do j = 1, 5, 2
+ ii = lbound (b, 1)
+ do i = 2, 8, 3
+ if (b(ii,jj)%i .ne. i) stop 107
+ if (b(ii,jj)%j .ne. j) stop 108
+ ii = ii + 1
+ end do
+ jj = jj + 1
+ end do
+
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-1.f90
new file mode 100644
index 00000000000..d42900163a2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-1.f90
@@ -0,0 +1,123 @@
+! { dg-do run }
+!
+! This program checks that passing arrays as assumed-shape dummies to
+! and from Fortran functions with C binding works.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer, parameter :: imax=10, jmax=5
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ type(m) :: aa(imax,jmax)
+ integer :: i, j
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = i
+ aa(i,j)%j = j
+ end do
+ end do
+
+ call testc (aa)
+ call testf (aa)
+
+contains
+
+ ! C binding version
+
+ subroutine checkc (a, b) bind (c)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:), b(:,:)
+ integer :: i, j
+
+ if (size (a,1) .ne. imax) stop 101
+ if (size (a,2) .ne. jmax) stop 102
+ if (size (b,1) .ne. jmax) stop 103
+ if (size (b,2) .ne. imax) stop 104
+
+ do j = 1, jmax
+ do i = 1, imax
+ if (a(i,j)%i .ne. i) stop 105
+ if (a(i,j)%j .ne. j) stop 106
+ if (b(j,i)%i .ne. i) stop 107
+ if (b(j,i)%j .ne. j) stop 108
+ end do
+ end do
+ end subroutine
+
+ ! Fortran binding version
+ subroutine checkf (a, b)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:), b(:,:)
+ integer :: i, j
+
+ if (size (a,1) .ne. imax) stop 201
+ if (size (a,2) .ne. jmax) stop 202
+ if (size (b,1) .ne. jmax) stop 203
+ if (size (b,2) .ne. imax) stop 204
+
+ do j = 1, jmax
+ do i = 1, imax
+ if (a(i,j)%i .ne. i) stop 205
+ if (a(i,j)%j .ne. j) stop 206
+ if (b(j,i)%i .ne. i) stop 207
+ if (b(j,i)%j .ne. j) stop 208
+ end do
+ end do
+ end subroutine
+
+ ! C binding version
+ subroutine testc (a) bind (c)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ type(m) :: b(jmax, imax)
+ integer :: i, j
+
+ if (size (a,1) .ne. imax) stop 301
+ if (size (a,2) .ne. jmax) stop 302
+ do j = 1, jmax
+ do i = 1, imax
+ b(j,i)%i = a(i,j)%i
+ b(j,i)%j = a(i,j)%j
+ end do
+ end do
+
+ ! Call both the C and Fortran binding check functions
+ call checkc (a, b)
+ call checkf (a, b)
+ end subroutine
+
+ ! Fortran binding version
+ subroutine testf (a)
+ use iso_c_binding
+ use mm
+ type(m) :: a(:,:)
+ type(m) :: b(jmax, imax)
+ integer :: i, j
+
+ if (size (a,1) .ne. imax) stop 401
+ if (size (a,2) .ne. jmax) stop 402
+ do j = 1, jmax
+ do i = 1, imax
+ b(j,i)%i = a(i,j)%i
+ b(j,i)%j = a(i,j)%j
+ end do
+ end do
+
+ ! Call both the C and Fortran binding check functions
+ call checkc (a, b)
+ call checkf (a, b)
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-2.f90
new file mode 100644
index 00000000000..d9b495732ea
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-2.f90
@@ -0,0 +1,97 @@
+! { dg-do run }
+!
+! This program checks that passing arrays as assumed-rank dummies to
+! and from Fortran functions with C binding works.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer, parameter :: imax=10, jmax=5
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ type(m) :: aa(imax,jmax)
+ integer :: i, j
+ do j = 1, jmax
+ do i = 1, imax
+ aa(i,j)%i = i
+ aa(i,j)%j = j
+ end do
+ end do
+
+ call testc (aa)
+ call testf (aa)
+
+contains
+
+ ! C binding version
+
+ subroutine checkc (a, b) bind (c)
+ use iso_c_binding
+ use mm
+ type(m) :: a(..), b(..)
+
+ if (rank (a) .ne. 2) stop 101
+ if (rank (b) .ne. 2) stop 102
+ if (size (a,1) .ne. imax) stop 103
+ if (size (a,2) .ne. jmax) stop 104
+ if (size (b,1) .ne. jmax) stop 105
+ if (size (b,2) .ne. imax) stop 106
+
+ end subroutine
+
+ ! Fortran binding version
+ subroutine checkf (a, b)
+ use iso_c_binding
+ use mm
+ type(m) :: a(..), b(..)
+
+ if (rank (a) .ne. 2) stop 201
+ if (rank (b) .ne. 2) stop 202
+ if (size (a,1) .ne. imax) stop 203
+ if (size (a,2) .ne. jmax) stop 204
+ if (size (b,1) .ne. jmax) stop 205
+ if (size (b,2) .ne. imax) stop 206
+
+ end subroutine
+
+ ! C binding version
+ subroutine testc (a) bind (c)
+ use iso_c_binding
+ use mm
+ type(m) :: a(..)
+ type(m) :: b(jmax, imax)
+
+ if (rank (a) .ne. 2) stop 301
+ if (size (a,1) .ne. imax) stop 302
+ if (size (a,2) .ne. jmax) stop 303
+
+ ! Call both the C and Fortran binding check functions
+ call checkc (a, b)
+ call checkf (a, b)
+ end subroutine
+
+ ! Fortran binding version
+ subroutine testf (a)
+ use iso_c_binding
+ use mm
+ type(m) :: a(..)
+ type(m) :: b(jmax, imax)
+
+ if (rank (a) .ne. 2) stop 401
+ if (size (a,1) .ne. imax) stop 402
+ if (size (a,2) .ne. jmax) stop 403
+
+ ! Call both the C and Fortran binding check functions
+ call checkc (a, b)
+ call checkf (a, b)
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-3.f90
new file mode 100644
index 00000000000..13ec8510d93
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-3.f90
@@ -0,0 +1,148 @@
+! { dg-do run }
+!
+! This program checks that passing allocatable and pointer scalars to
+! and from Fortran functions with C binding works.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+
+ integer, parameter :: imagic=-1, jmagic=42
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ type(m), allocatable :: a
+ type(m), target :: t
+ type(m), pointer :: p
+
+ p => NULL()
+
+ call testc (a, t, p)
+ call testf (a, t, p)
+
+contains
+
+ ! C binding version
+
+ subroutine checkc (a, t, p, initp) bind (c)
+ use iso_c_binding
+ use mm
+ type(m), allocatable :: a
+ type(m), target :: t
+ type(m), pointer :: p
+ logical, value :: initp
+
+ if (initp) then
+ if (.not. allocated (a)) stop 101
+ if (a%i .ne. imagic) stop 102
+ if (a%j .ne. jmagic) stop 103
+ if (.not. associated (p)) stop 104
+ if (.not. associated (p, t)) stop 105
+ if (p%i .ne. imagic) stop 106
+ if (p%j .ne. jmagic) stop 107
+ else
+ if (allocated (a)) stop 108
+ if (associated (p)) stop 109
+ end if
+
+ if (rank (a) .ne. 0) stop 110
+ if (rank (t) .ne. 0) stop 111
+ if (rank (p) .ne. 0) stop 112
+
+ end subroutine
+
+ ! Fortran binding version
+ subroutine checkf (a, t, p, initp)
+ use iso_c_binding
+ use mm
+ type(m), allocatable :: a
+ type(m), target :: t
+ type(m), pointer :: p
+ logical, value :: initp
+
+ if (initp) then
+ if (.not. allocated (a)) stop 201
+ if (a%i .ne. imagic) stop 202
+ if (a%j .ne. jmagic) stop 203
+ if (.not. associated (p)) stop 204
+ if (.not. associated (p, t)) stop 205
+ if (p%i .ne. imagic) stop 206
+ if (p%j .ne. jmagic) stop 207
+ else
+ if (allocated (a)) stop 208
+ if (associated (p)) stop 209
+ end if
+
+ if (rank (a) .ne. 0) stop 210
+ if (rank (t) .ne. 0) stop 211
+ if (rank (p) .ne. 0) stop 212
+
+ end subroutine
+
+ ! C binding version
+ subroutine testc (a, t, p) bind (c)
+ use iso_c_binding
+ use mm
+ type(m), allocatable :: a
+ type(m), target :: t
+ type(m), pointer :: p
+
+ ! Call both the C and Fortran binding check functions
+ call checkc (a, t, p, .false.)
+ call checkf (a, t, p, .false.)
+
+ ! Allocate/associate and check again.
+ allocate (a)
+ a%i = imagic
+ a%j = jmagic
+ p => t
+ t%i = imagic
+ t%j = jmagic
+ call checkc (a, t, p, .true.)
+ call checkf (a, t, p, .true.)
+
+ ! Reset and check a third time.
+ deallocate (a)
+ p => NULL ()
+ call checkc (a, t, p, .false.)
+ call checkf (a, t, p, .false.)
+
+ end subroutine
+
+ ! Fortran binding version
+ subroutine testf (a, t, p)
+ use iso_c_binding
+ use mm
+ type(m), allocatable :: a
+ type(m), target :: t
+ type(m), pointer :: p
+
+ ! Call both the C and Fortran binding check functions
+ call checkc (a, t, p, .false.)
+ call checkf (a, t, p, .false.)
+
+ ! Allocate/associate and check again.
+ allocate (a)
+ a%i = imagic
+ a%j = jmagic
+ p => t
+ t%i = imagic
+ t%j = jmagic
+ call checkc (a, t, p, .true.)
+ call checkf (a, t, p, .true.)
+
+ ! Reset and check a third time.
+ deallocate (a)
+ p => NULL ()
+ call checkc (a, t, p, .false.)
+ call checkf (a, t, p, .false.)
+
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-4.f90
new file mode 100644
index 00000000000..fd15d0687f1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-4.f90
@@ -0,0 +1,198 @@
+! { dg-do run }
+!
+! This program checks that passing allocatable and pointer arrays to
+! and from Fortran functions with C binding works.
+
+module mm
+ use iso_c_binding
+ type, bind (c) :: m
+ integer(C_INT) :: i, j
+ end type
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ type(m), allocatable :: a(:)
+ type(m), target :: t(3,10)
+ type(m), pointer :: p(:,:)
+
+ p => NULL()
+
+ call testc (a, t, p)
+ call testf (a, t, p)
+
+contains
+
+ ! C binding version
+
+ subroutine checkc (a, t, p, initp) bind (c)
+ use iso_c_binding
+ use mm
+ type(m), allocatable :: a(:)
+ type(m), target :: t(3,10)
+ type(m), pointer :: p(:,:)
+ logical, value :: initp
+ integer :: i, j
+
+ if (rank (a) .ne. 1) stop 101
+ if (rank (t) .ne. 2) stop 102
+ if (rank (p) .ne. 2) stop 103
+
+ if (initp) then
+ if (.not. allocated (a)) stop 104
+ if (.not. associated (p)) stop 105
+ if (.not. associated (p, t)) stop 106
+ if (size (a, 1) .ne. 5) stop 107
+ if (size (p, 1) .ne. 3) stop 108
+ if (size (p, 2) .ne. 10) stop 109
+ else
+ if (allocated (a)) stop 121
+ if (associated (p)) stop 122
+ end if
+
+ end subroutine
+
+ ! Fortran binding version
+ subroutine checkf (a, t, p, initp)
+ use iso_c_binding
+ use mm
+ type(m), allocatable :: a(:)
+ type(m), target :: t(3,10)
+ type(m), pointer :: p(:,:)
+ logical, value :: initp
+ integer :: i, j
+
+ if (rank (a) .ne. 1) stop 201
+ if (rank (t) .ne. 2) stop 202
+ if (rank (p) .ne. 2) stop 203
+
+ if (initp) then
+ if (.not. allocated (a)) stop 204
+ if (.not. associated (p)) stop 205
+ if (.not. associated (p, t)) stop 206
+ if (size (a, 1) .ne. 5) stop 207
+ if (size (p, 1) .ne. 3) stop 208
+ if (size (p, 2) .ne. 10) stop 209
+ else
+ if (allocated (a)) stop 221
+ if (associated (p)) stop 222
+ end if
+
+ end subroutine
+
+ ! C binding version
+ subroutine allocatec (a, t, p) bind (c)
+ use iso_c_binding
+ use mm
+ type(m), allocatable :: a(:)
+ type(m), target :: t(3,10)
+ type(m), pointer :: p(:,:)
+
+ allocate (a(10:20))
+ p => t
+ end subroutine
+
+ ! Fortran binding version
+ subroutine allocatef (a, t, p) bind (c)
+ use iso_c_binding
+ use mm
+ type(m), allocatable :: a(:)
+ type(m), target :: t(3,10)
+ type(m), pointer :: p(:,:)
+
+ allocate (a(5:15))
+ p => t
+ end subroutine
+
+ ! C binding version
+ subroutine testc (a, t, p) bind (c)
+ use iso_c_binding
+ use mm
+ type(m), allocatable :: a(:)
+ type(m), target :: t(3,10)
+ type(m), pointer :: p(:,:)
+
+ ! Call both the C and Fortran binding check functions
+ call checkc (a, t, p, .false.)
+ call checkf (a, t, p, .false.)
+
+ ! Allocate/associate and check again.
+ allocate (a(5))
+ p => t
+ call checkc (a, t, p, .true.)
+ call checkf (a, t, p, .true.)
+
+ ! Reset and check a third time.
+ deallocate (a)
+ p => NULL ()
+ call checkc (a, t, p, .false.)
+ call checkf (a, t, p, .false.)
+
+ ! Allocate/associate inside a function with Fortran binding.
+ call allocatef (a, t, p)
+ if (.not. allocated (a)) stop 301
+ if (.not. associated (p)) stop 302
+ if (lbound (a, 1) .ne. 5) stop 303
+ if (ubound (a, 1) .ne. 15) stop 304
+ deallocate (a)
+ p => NULL ()
+
+ ! Allocate/associate inside a function with C binding.
+ call allocatec (a, t, p)
+ if (.not. allocated (a)) stop 311
+ if (.not. associated (p)) stop 312
+ if (lbound (a, 1) .ne. 10) stop 313
+ if (ubound (a, 1) .ne. 20) stop 314
+ deallocate (a)
+ p => NULL ()
+
+ end subroutine
+
+ ! Fortran binding version
+ subroutine testf (a, t, p)
+ use iso_c_binding
+ use mm
+ type(m), allocatable :: a(:)
+ type(m), target :: t(3,10)
+ type(m), pointer :: p(:,:)
+
+ ! Call both the C and Fortran binding check functions
+ call checkc (a, t, p, .false.)
+ call checkf (a, t, p, .false.)
+
+ ! Allocate/associate and check again.
+ allocate (a(5))
+ p => t
+ call checkc (a, t, p, .true.)
+ call checkf (a, t, p, .true.)
+
+ ! Reset and check a third time.
+ deallocate (a)
+ p => NULL ()
+ call checkc (a, t, p, .false.)
+ call checkf (a, t, p, .false.)
+
+ ! Allocate/associate inside a function with Fortran binding.
+ call allocatef (a, t, p)
+ if (.not. allocated (a)) stop 401
+ if (.not. associated (p)) stop 402
+ if (lbound (a, 1) .ne. 5) stop 403
+ if (ubound (a, 1) .ne. 15) stop 404
+ deallocate (a)
+ p => NULL ()
+
+ ! Allocate/associate inside a function with C binding.
+ call allocatec (a, t, p)
+ if (.not. allocated (a)) stop 411
+ if (.not. associated (p)) stop 412
+ if (lbound (a, 1) .ne. 10) stop 413
+ if (ubound (a, 1) .ne. 20) stop 414
+ deallocate (a)
+ p => NULL ()
+
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-5.f90
new file mode 100644
index 00000000000..2420b7d3731
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-5.f90
@@ -0,0 +1,61 @@
+! PR92482
+! { dg-do run }
+!
+! This program checks that passing arrays as assumed-length character
+! dummies to and from Fortran functions with C binding works.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ character(len=26,kind=C_CHAR) :: aa
+
+ call testc (aa)
+ call testf (aa)
+
+contains
+
+ ! C binding version
+
+ subroutine checkc (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ use iso_c_binding
+ character(len=*,kind=C_CHAR) :: a
+
+ if (rank (a) .ne. 0) stop 101
+ if (len (a) .ne. 26) stop 102
+ if (a .ne. 'abcdefghijklmnopqrstuvwxyz') stop 103
+ end subroutine
+
+ ! Fortran binding version
+ subroutine checkf (a)
+ use iso_c_binding
+ character(len=*,kind=C_CHAR) :: a
+
+ if (rank (a) .ne. 0) stop 201
+ if (len (a) .ne. 26) stop 202
+ if (a .ne. 'abcdefghijklmnopqrstuvwxyz') stop 203
+ end subroutine
+
+ ! C binding version
+ subroutine testc (a) bind (c) ! { dg-bogus "Sorry" "pr92482" { xfail *-*-* } }
+ use iso_c_binding
+ character(len=*,kind=C_CHAR) :: a
+
+ ! Call both the C and Fortran binding check functions
+ a = 'abcdefghijklmnopqrstuvwxyz'
+ call checkc (a)
+ call checkf (a)
+ end subroutine
+
+ ! Fortran binding version
+ subroutine testf (a)
+ use iso_c_binding
+ character(len=*,kind=C_CHAR) :: a
+
+ ! Call both the C and Fortran binding check functions
+ a = 'abcdefghijklmnopqrstuvwxyz'
+ call checkc (a)
+ call checkf (a)
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-6.f90
new file mode 100644
index 00000000000..8b1167e65fe
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-6.f90
@@ -0,0 +1,71 @@
+! Reported as pr94070.
+! { dg-do run { xfail *-*-* } }
+!
+! This program checks that passing assumed-size arrays to
+! and from Fortran functions with C binding works.
+!
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ ! Assumed-size arrays are not passed by descriptor. What we'll do
+ ! for this test function is bind an assumed-rank dummy
+ ! to the assumed-size array. This is supposed to fill in the descriptor
+ ! with information about the array present at the call site.
+ interface
+ subroutine ctest (a) bind (c)
+ use iso_c_binding
+ integer(C_INT) :: a(..)
+ end subroutine
+ end interface
+
+ integer(C_INT), target :: aa(10,5:8)
+
+ ! To get an assumed-size array descriptor, we have to first pass the
+ ! fixed-size array to a Fortran function with an assumed-size dummy,
+ call ftest1 (aa)
+ call ftest2 (aa)
+ call ftest3 (aa)
+
+contains
+ subroutine ftest1 (a)
+ use iso_c_binding
+ integer(C_INT) :: a(10,*)
+ call testf (a)
+ call testc (a)
+ end subroutine
+ subroutine ftest2 (a)
+ use iso_c_binding
+ integer(C_INT) :: a(10,5:*)
+ call testf (a)
+ call testc (a)
+ end subroutine
+ subroutine ftest3 (a) bind (c)
+ use iso_c_binding
+ integer(C_INT) :: a(10,1:*)
+ call testf (a)
+ call testc (a)
+ end subroutine
+
+ subroutine testf (a)
+ use iso_c_binding
+ integer(C_INT) :: a(..)
+ if (rank (a) .ne. 2) stop 101
+ print *, size (a, 1), size (a, 2)
+ if (size (a, 1) .ne. 10) stop 102
+ if (size (a, 2) .ne. -1) stop 103
+ if (any (lbound (a) .eq. 0)) stop 104
+ end subroutine
+
+ subroutine testc (a) bind (c)
+ use iso_c_binding
+ integer(C_INT) :: a(..)
+ if (rank (a) .ne. 2) stop 201
+ print *, size (a, 1), size (a, 2)
+ if (size (a, 1) .ne. 10) stop 202
+ if (size (a, 2) .ne. -1) stop 203
+ if (any (lbound (a) .eq. 0)) stop 204
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-7.f90 b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-7.f90
new file mode 100644
index 00000000000..3d3c77216ca
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-7.f90
@@ -0,0 +1,89 @@
+! { dg-do run }
+!
+! Test that arrays that may not be contiguous can be passed both ways
+! between Fortran subroutines with C and Fortran binding conventions.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ integer(C_INT), target :: aa(10,5)
+ integer(C_INT), target :: bb(10,10)
+
+ integer :: i, j, n
+
+ ! Test both C and Fortran binding.
+ n = 0
+ do j = 1, 10
+ do i = 1, 5
+ aa(j,i) = n
+ n = n + 1
+ end do
+ end do
+ call testc (transpose (aa))
+ call testf (transpose (aa))
+
+ bb = -1
+ n = 0
+ do j = 1, 10
+ do i = 2, 10, 2
+ bb(i,j) = n
+ n = n + 1
+ end do
+ end do
+ call testc (bb(2:10:2, :))
+ call testf (bb(2:10:2, :))
+
+contains
+
+ subroutine testc (a) bind (c)
+ use iso_c_binding
+ integer(C_INT), intent(in) :: a(:,:)
+ call checkc (a)
+ call checkf (a)
+ end subroutine
+
+ subroutine testf (a)
+ use iso_c_binding
+ integer(C_INT), intent(in) :: a(:,:)
+ call checkc (a)
+ call checkf (a)
+ end subroutine
+
+ subroutine checkc (a) bind (c)
+ use iso_c_binding
+ integer(C_INT), intent(in) :: a(:,:)
+ integer :: i, j, n
+
+ if (rank (a) .ne. 2) stop 101
+ if (size (a, 1) .ne. 5) stop 102
+ if (size (a, 2) .ne. 10) stop 103
+
+ n = 0
+ do j = 1, 10
+ do i = 1, 5
+ if (a(i,j) .ne. n) stop 104
+ n = n + 1
+ end do
+ end do
+ end subroutine
+
+ subroutine checkf (a)
+ use iso_c_binding
+ integer(C_INT), intent(in) :: a(:,:)
+ integer :: i, j, n
+
+ if (rank (a) .ne. 2) stop 101
+ if (size (a, 1) .ne. 5) stop 102
+ if (size (a, 2) .ne. 10) stop 103
+
+ n = 0
+ do j = 1, 10
+ do i = 1, 5
+ if (a(i,j) .ne. n) stop 104
+ n = n + 1
+ end do
+ end do
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/note-5-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/note-5-3.f90
new file mode 100644
index 00000000000..253f0efd1ed
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/note-5-3.f90
@@ -0,0 +1,55 @@
+! { dg-do run }
+!
+! TS 29113
+! NOTE 5.3
+! The intrinsic inquiry function RANK can be used to inquire about the
+! rank of a data object. The rank of an assumed-rank object is zero if
+! the rank of the corresponding actual argument is zero.
+
+program test
+
+ integer :: scalar, array_1d(10), array_2d(3, 3)
+
+ call testit (scalar, array_1d, array_2d)
+
+contains
+
+ function test_rank (a)
+ integer :: test_rank
+ integer :: a(..)
+
+ test_rank = rank (a)
+ end function
+
+ subroutine testit (a0, a1, a2)
+ integer :: a0(..), a1(..), a2(..)
+
+ integer, target :: b0, b1(10), b2(3, 3)
+ integer, allocatable :: c0, c1(:), c2(:,:)
+ integer, pointer :: d0, d1(:), d2(:,:)
+
+ ! array descriptor passed from caller through testit to test_rank
+ if (test_rank (a0) .ne. 0) stop 100
+ if (test_rank (a1) .ne. 1) stop 101
+ if (test_rank (a2) .ne. 2) stop 102
+
+ ! array descriptor created locally here, fixed size
+ if (test_rank (b0) .ne. 0) stop 200
+ if (test_rank (b1) .ne. 1) stop 201
+ if (test_rank (b2) .ne. 2) stop 202
+
+ ! allocatable arrays don't actually have to be allocated.
+ if (test_rank (c0) .ne. 0) stop 300
+ if (test_rank (c1) .ne. 1) stop 301
+ if (test_rank (c2) .ne. 2) stop 302
+
+ ! pointer arrays do need to point at something.
+ d0 => b0
+ d1 => b1
+ d2 => b2
+ if (test_rank (d0) .ne. 0) stop 400
+ if (test_rank (d1) .ne. 1) stop 401
+ if (test_rank (d2) .ne. 2) stop 402
+
+ end subroutine
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/note-5-4-c.c b/gcc/testsuite/gfortran.dg/c-interop/note-5-4-c.c
new file mode 100644
index 00000000000..ab278460a58
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/note-5-4-c.c
@@ -0,0 +1,10 @@
+#include <ISO_Fortran_binding.h>
+
+extern int test_rank (CFI_cdesc_t *a);
+
+int test_rank (CFI_cdesc_t *a)
+{
+ if (!a)
+ return -1; /* Should not happen. */
+ return a->rank;
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/note-5-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/note-5-4.f90
new file mode 100644
index 00000000000..9f3fc8e2ca7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/note-5-4.f90
@@ -0,0 +1,63 @@
+! { dg-do run }
+! { dg-additional-sources note-5-4-c.c }
+!
+! TS 29113
+! NOTE 5.4
+! Assumed rank is an attribute of a Fortran dummy argument. When a C
+! function is invoked with an actual argument that corresponds to an
+! assumed-rank dummy argument in a Fortran interface for that C function,
+! the corresponding formal parameter is the address of a descriptor of
+! type CFI_cdesc_t (8.7). The rank member of the descriptor provides the
+! rank of the actual argument. The C function should therefore be able
+! to handle any rank. On each invocation, the rank is available to it.
+
+program test
+
+ interface
+ function test_rank (a) bind (c, name="test_rank")
+ integer :: test_rank
+ integer :: a(..)
+ end function
+ end interface
+
+ integer :: scalar, array_1d(10), array_2d(3, 3)
+
+ call testit (scalar, array_1d, array_2d)
+
+contains
+
+ subroutine testit (a0, a1, a2)
+ integer :: a0(..), a1(..), a2(..)
+
+ integer, target :: b0, b1(10), b2(3, 3)
+ integer, allocatable :: c0, c1(:), c2(:,:)
+ integer, pointer :: d0, d1(:), d2(:,:)
+
+ ! array descriptor passed from caller through testit to test_rank
+ if (test_rank (a0) .ne. 0) stop 100
+ if (test_rank (a1) .ne. 1) stop 101
+ if (test_rank (a2) .ne. 2) stop 102
+
+ ! array descriptor created locally here, fixed size
+ if (test_rank (b0) .ne. 0) stop 200
+ if (test_rank (b1) .ne. 1) stop 201
+ if (test_rank (b2) .ne. 2) stop 202
+
+ ! allocatables
+ allocate (c0)
+ allocate (c1 (10))
+ allocate (c2 (3, 3))
+ if (test_rank (c0) .ne. 0) stop 300
+ if (test_rank (c1) .ne. 1) stop 301
+ if (test_rank (c2) .ne. 2) stop 302
+
+ ! pointers
+ d0 => b0
+ d1 => b1
+ d2 => b2
+ if (test_rank (d0) .ne. 0) stop 400
+ if (test_rank (d1) .ne. 1) stop 401
+ if (test_rank (d2) .ne. 2) stop 402
+
+ end subroutine
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/optional-c.c b/gcc/testsuite/gfortran.dg/c-interop/optional-c.c
new file mode 100644
index 00000000000..9612d283486
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/optional-c.c
@@ -0,0 +1,82 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ftest (int n, CFI_cdesc_t *a, int *b, char *c, double *d);
+extern void ctest1 (CFI_cdesc_t *a, int *b, char *c, double *d);
+extern void ctest2 (int n, CFI_cdesc_t *a, int *b, char *c, double *d);
+
+static void *aa;
+static int *bb;
+static char *cc;
+static double *dd;
+
+extern void
+ctest1 (CFI_cdesc_t *a, int *b, char *c, double *d)
+{
+ /* Cache all the pointer arguments for later use by ctest2. */
+ aa = a->base_addr;
+ bb = b;
+ cc = c;
+ dd = d;
+
+ /* Test calling back into Fortran. */
+ ftest (0, NULL, NULL, NULL, NULL);
+ ftest (1, a, NULL, NULL, NULL);
+ ftest (2, a, b, NULL, NULL);
+ ftest (3, a, b, c, NULL);
+ ftest (4, a, b, c, d);
+}
+
+extern void
+ctest2 (int n, CFI_cdesc_t *a, int *b, char *c, double *d)
+{
+ if (n >= 1)
+ {
+ if (!a)
+ abort ();
+ if (a->base_addr != aa)
+ abort ();
+ }
+ else
+ if (a)
+ abort ();
+
+ if (n >= 2)
+ {
+ if (!b)
+ abort ();
+ if (*b != *bb)
+ abort ();
+ }
+ else
+ if (b)
+ abort ();
+
+ if (n >= 3)
+ {
+ if (!c)
+ abort ();
+ if (*c != *cc)
+ abort ();
+ }
+ else
+ if (c)
+ abort ();
+
+ if (n >= 4)
+ {
+ if (!d)
+ abort ();
+ if (*d != *dd)
+ abort ();
+ }
+ else
+ if (d)
+ abort ();
+
+}
+
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/optional.f90 b/gcc/testsuite/gfortran.dg/c-interop/optional.f90
new file mode 100644
index 00000000000..2a304108c38
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/optional.f90
@@ -0,0 +1,114 @@
+! { dg-do run }
+! { dg-additional-sources "optional-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! TS 29113
+! 8.7 An absent actual argument in a reference to an interoperable
+! procedure is indicated by a corresponding formal parameter with the
+! value of a null pointer. An absent optional dummy argument in a
+! reference to an interoperable procedure from a C function is indicated
+! by a corresponding argument with the value of a null pointer.
+
+module m
+ use iso_c_binding
+ integer(C_INT) :: aa(32)
+ integer(C_INT) :: bb
+ character(C_CHAR) :: cc
+ real(C_DOUBLE) :: dd
+end module
+
+subroutine ftest (n, a, b, c, d) bind (c)
+ use iso_c_binding
+ use m
+ implicit none
+ integer(C_INT), value :: n
+ integer(C_INT), optional :: a(:)
+ integer(C_INT), optional :: b
+ character(C_CHAR), optional :: c
+ real(C_DOUBLE), optional :: d
+
+ if (n .ge. 1) then
+ if (.not. present (a)) stop 101
+ if (any (a .ne. aa)) stop 201
+ else
+ if (present (a)) stop 301
+ end if
+
+ if (n .ge. 2) then
+ if (.not. present (b)) stop 102
+ if (b .ne. bb) stop 201
+ else
+ if (present (b)) stop 302
+ end if
+
+ if (n .ge. 3) then
+ if (.not. present (c)) stop 103
+ if (c .ne. cc) stop 201
+ else
+ if (present (c)) stop 303
+ end if
+
+ if (n .ge. 4) then
+ if (.not. present (d)) stop 104
+ if (d .ne. dd) stop 201
+ else
+ if (present (d)) stop 304
+ end if
+end subroutine
+
+program testit
+ use iso_c_binding
+ use m
+ implicit none
+
+ interface
+ subroutine ctest1 (a, b, c, d) bind (c)
+ use iso_c_binding
+ integer(C_INT) :: a(:)
+ integer(C_INT) :: b
+ character(C_CHAR) :: c
+ real(C_DOUBLE) :: d
+ end subroutine
+ subroutine ctest2 (n, a, b, c, d) bind (c)
+ use iso_c_binding
+ integer(C_INT), value :: n
+ integer(C_INT), optional :: a(:)
+ integer(C_INT), optional :: b
+ character(C_CHAR), optional :: c
+ real(C_DOUBLE), optional :: d
+ end subroutine
+ subroutine ftest (n, a, b, c, d) bind (c)
+ use iso_c_binding
+ integer(C_INT), value :: n
+ integer(C_INT), optional :: a(:)
+ integer(C_INT), optional :: b
+ character(C_CHAR), optional :: c
+ real(C_DOUBLE), optional :: d
+ end subroutine
+ end interface
+
+
+ ! Initialize the variables above.
+ integer :: i
+ do i = 1, 32
+ aa(i) = i
+ end do
+ bb = 42
+ cc = '$'
+ dd = acos(-1.D0)
+
+ call ftest (0)
+ call ftest (1, aa)
+ call ftest (2, aa, bb)
+ call ftest (3, aa, bb, cc)
+ call ftest (4, aa, bb, cc, dd)
+
+ call ctest1 (aa, bb, cc, dd)
+ call ctest2 (0)
+ call ctest2 (1, aa)
+ call ctest2 (2, aa, bb)
+ call ctest2 (3, aa, bb, cc)
+ call ctest2 (4, aa, bb, cc, dd)
+
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/rank-class.f90 b/gcc/testsuite/gfortran.dg/c-interop/rank-class.f90
new file mode 100644
index 00000000000..bbf1839e359
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/rank-class.f90
@@ -0,0 +1,88 @@
+! { dg-do run }
+!
+! TS 29113
+! 7.2 RANK (A)
+! Description. Rank of a data object.
+! Class. Inquiry function.
+! Argument.
+! A shall be a scalar or array of any type.
+! Result Characteristics. Default integer scalar.
+! Result Value. The result is the rank of A.
+
+module m
+
+ type :: base
+ integer :: a, b
+ end type
+
+ type, extends (base) :: derived
+ integer :: c
+ end type
+end module
+
+program test
+ use m
+
+ ! Define some arrays for testing.
+ type(derived), target :: x1(5)
+ type(derived) :: y1(0:9)
+ type(derived), pointer :: p1(:)
+ type(derived), allocatable :: a1(:)
+ type(derived), target :: x3(2,3,4)
+ type(derived) :: y3(0:1,-3:-1,4)
+ type(derived), pointer :: p3(:,:,:)
+ type(derived), allocatable :: a3(:,:,:)
+ type(derived) :: x
+
+ ! Test the 1-dimensional arrays.
+ if (rank (x1) .ne. 1) stop 201
+ call testit (x1, 1)
+ if (rank (y1) .ne. 1) stop 202
+ call testit (y1, 1)
+ if (rank (p1) .ne. 1) stop 203
+ p1 => x1
+ call testit (p1, 1)
+ if (rank (p1) .ne. 1) stop 204
+ if (rank (a1) .ne. 1) stop 205
+ allocate (a1(5))
+ if (rank (a1) .ne. 1) stop 206
+ call testit (a1, 1)
+
+ ! Test the multi-dimensional arrays.
+ if (rank (x3) .ne. 3) stop 207
+ call testit (x3, 3)
+ if (rank (y3) .ne. 3) stop 208
+ if (rank (p3) .ne. 3) stop 209
+ p3 => x3
+ call testit (p3, 3)
+ if (rank (p3) .ne. 3) stop 210
+ if (rank (a3) .ne. 3) stop 211
+ allocate (a3(2,3,4))
+ call testit (a3, 3)
+ if (rank (a3) .ne. 3) stop 212
+
+ ! Test scalars.
+ if (rank (x) .ne. 0) stop 213
+ call testit (x, 0)
+ call test0 (x)
+ if (rank (x1(1)) .ne. 0) stop 215
+ call test0 (x1(1))
+
+contains
+
+ subroutine testit (a, r)
+ use m
+ class(base) :: a(..)
+ integer :: r
+
+ if (r .ne. rank(a)) stop 101
+ end subroutine
+
+ subroutine test0 (a)
+ use m
+ class(base) :: a(..)
+ if (rank (a) .ne. 0) stop 103
+ call testit (a, 0)
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/rank.f90 b/gcc/testsuite/gfortran.dg/c-interop/rank.f90
new file mode 100644
index 00000000000..9bae575a9cd
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/rank.f90
@@ -0,0 +1,99 @@
+! { dg-do run }
+!
+! TS 29113
+! 7.2 RANK (A)
+! Description. Rank of a data object.
+! Class. Inquiry function.
+! Argument.
+! A shall be a scalar or array of any type.
+! Result Characteristics. Default integer scalar.
+! Result Value. The result is the rank of A.
+
+program test
+
+ ! Define some arrays for testing.
+ integer, target :: x1(5)
+ integer :: y1(0:9)
+ integer, pointer :: p1(:)
+ integer, allocatable :: a1(:)
+ integer, target :: x3(2,3,4)
+ integer :: y3(0:1,-3:-1,4)
+ integer, pointer :: p3(:,:,:)
+ integer, allocatable :: a3(:,:,:)
+ integer :: x
+
+ ! Test the 1-dimensional arrays.
+ if (rank (x1) .ne. 1) stop 201
+ call testit (x1, 1)
+ call test1 (x1)
+ if (rank (y1) .ne. 1) stop 202
+ call testit (y1, 1)
+ call test1 (y1)
+ if (rank (p1) .ne. 1) stop 203
+ p1 => x1
+ call testit (p1, 1)
+ if (rank (p1) .ne. 1) stop 204
+ call test1 (p1)
+ if (rank (a1) .ne. 1) stop 205
+ allocate (a1(5))
+ if (rank (a1) .ne. 1) stop 206
+ call testit (a1, 1)
+ call test1 (a1)
+
+ ! Test the multi-dimensional arrays.
+ if (rank (x3) .ne. 3) stop 207
+ call testit (x3, 3)
+ call test1 (x3)
+ call test3 (x3, 1, 2, 1, 3)
+ if (rank (y3) .ne. 3) stop 208
+ call test3 (y3, 0, 1, -3, -1)
+ if (rank (p3) .ne. 3) stop 209
+ p3 => x3
+ call testit (p3, 3)
+ call test1 (p3)
+ if (rank (p3) .ne. 3) stop 210
+ call test3 (p3, 1, 2, 1, 3)
+ if (rank (a3) .ne. 3) stop 211
+ allocate (a3(2,3,4))
+ call testit (a3, 3)
+ call test1 (a3)
+ if (rank (a3) .ne. 3) stop 212
+ call test3 (a3, 1, 2, 1, 3)
+
+ ! Test scalars.
+ if (rank (x) .ne. 0) stop 213
+ call testit (x, 0)
+ call test0 (x)
+ if (rank (-1) .ne. 0) stop 214
+ call test0 (-1)
+ if (rank (x1(1)) .ne. 0) stop 215
+ call test0 (x1(1))
+
+contains
+
+ subroutine testit (a, r)
+ integer :: a(..)
+ integer :: r
+
+ if (r .ne. rank(a)) stop 101
+ end subroutine
+
+ subroutine test0 (a)
+ integer :: a(..)
+ if (rank (a) .ne. 0) stop 103
+ call testit (a, 0)
+ end subroutine
+
+ subroutine test1 (a)
+ integer :: a(*)
+ call testit (a, 1)
+ end subroutine
+
+ subroutine test3 (a, l1, u1, l2, u2)
+ implicit none
+ integer :: l1, u1, l2, u2
+ integer :: a(l1:u1, l2:u2, *)
+ call testit (a, 3)
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-1.f90
new file mode 100644
index 00000000000..d2155ec6eeb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-1.f90
@@ -0,0 +1,41 @@
+! { dg-do compile}
+!
+! TS 29113
+! 8.1 Removed restrictions on ISO_C_BINDING module procedures
+!
+! The subroutine C_F_POINTER from the intrinsic module ISO_C_BINDING has
+! the restriction in ISO/IEC 1539- 1:2010 that if FPTR is an array, it
+! shall be of interoperable type.
+!
+! [...]
+!
+! These restrictions are removed.
+
+module m
+ use ISO_C_BINDING
+ implicit none
+
+ ! An obvious example of a type that isn't interoperable is a
+ ! derived type without a bind(c) clause.
+
+ integer :: buflen
+ parameter (buflen=256)
+
+ type :: packet
+ integer :: size
+ integer(1) :: buf(buflen)
+ end type
+
+contains
+
+ subroutine test (ptr, n, packets)
+ type(C_PTR), intent(in) :: ptr
+ integer, intent(in) :: n
+ type(packet), pointer, intent(out) :: packets(:)
+
+ integer :: s(1)
+ s(1) = n
+
+ call c_f_pointer (ptr, packets, s)
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-2.f90
new file mode 100644
index 00000000000..3c49de37152
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-2.f90
@@ -0,0 +1,35 @@
+! { dg-do compile}
+!
+! TS 29113
+! 8.1 Removed restrictions on ISO_C_BINDING module procedures
+!
+! The function C_F_PROCPOINTER from the intrinsic module ISO_C_BINDING
+! has the restriction in ISO/IEC 1539-1:2010 that CPTR and FPTR shall
+! not be the C address and interface of a noninteroperable Fortran
+! procedure.
+!
+! [...]
+!
+! These restrictions are removed.
+
+module m
+ use ISO_C_BINDING
+ implicit none
+
+ ! Declare a non-interoperable Fortran procedure interface.
+ abstract interface
+ function foo (x, y)
+ integer :: foo
+ integer, intent (in) :: x, y
+ end function
+ end interface
+
+contains
+
+ subroutine test (cptr, fptr)
+ type(C_FUNPTR), intent(in) :: cptr
+ procedure (foo), pointer, intent(out) :: fptr
+
+ call c_f_procpointer (cptr, fptr)
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-3.f90
new file mode 100644
index 00000000000..b429e8052c9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-3.f90
@@ -0,0 +1,37 @@
+! { dg-do compile}
+!
+! TS 29113
+! 8.1 Removed restrictions on ISO_C_BINDING module procedures
+!
+! The function C_LOC from the intrinsic module ISO_C_BINDING has the
+! restriction in ISO/IEC 1539-1:2010 that if X is an array, it shall
+! be of interoperable type.
+!
+! [...]
+!
+! These restrictions are removed.
+
+module m
+ use ISO_C_BINDING
+ implicit none
+
+ ! An obvious example of a type that isn't interoperable is a
+ ! derived type without a bind(c) clause.
+
+ integer :: buflen
+ parameter (buflen=256)
+
+ type :: packet
+ integer :: size
+ integer(1) :: buf(buflen)
+ end type
+
+contains
+
+ subroutine test (packets, ptr)
+ type(packet), pointer, intent(in) :: packets(:)
+ type(C_PTR), intent(out) :: ptr
+
+ ptr = c_loc (packets)
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-4.f90
new file mode 100644
index 00000000000..b44defd40e1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-4.f90
@@ -0,0 +1,34 @@
+! { dg-do compile}
+!
+! TS 29113
+! 8.1 Removed restrictions on ISO_C_BINDING module procedures
+!
+! [...]
+!
+! The function C_FUNLOC from the intrinsic module ISO_C_BINDING has
+! the restriction in ISO/IEC 1539-1:2010 that its argument shall be
+! interoperable.
+!
+! These restrictions are removed.
+
+module m
+ use ISO_C_BINDING
+ implicit none
+
+ ! Declare a non-interoperable Fortran procedure interface.
+ abstract interface
+ function foo (x, y)
+ integer :: foo
+ integer, intent (in) :: x, y
+ end function
+ end interface
+
+contains
+
+ subroutine test (fptr, cptr)
+ procedure (foo), pointer, intent(in) :: fptr
+ type(C_FUNPTR), intent(out) :: cptr
+
+ cptr = c_funloc (fptr)
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/c-interop/section-1-c.c b/gcc/testsuite/gfortran.dg/c-interop/section-1-c.c
new file mode 100644
index 00000000000..7da86a4f2b3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/section-1-c.c
@@ -0,0 +1,135 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *a, int lb, int ub, int s, CFI_cdesc_t *r);
+
+/* Take a section of array A. OFF is the start index of A on the Fortran
+ side and the bounds LB and UB for the section to take are relative to
+ that base index. Store the result in R, which is supposed to be a pointer
+ array with lower bound 1. */
+
+void
+ctest (CFI_cdesc_t *a, int lb, int ub, int s, CFI_cdesc_t *r)
+{
+ CFI_index_t lb_array[1], ub_array[1], s_array[1];
+ CFI_index_t i, o;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ fprintf (stderr, "\n%s: lb=%d ub=%d s=%d\n",
+ (a->attribute == CFI_attribute_other) ? "non-pointer" : "pointer",
+ lb, ub, s);
+ dump_CFI_cdesc_t (a);
+ dump_CFI_cdesc_t (r);
+
+ /* Make sure we got a valid input descriptor. */
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof(int))
+ abort ();
+ if (a->rank != 1)
+ abort ();
+ if (a->type != CFI_type_int)
+ abort ();
+ if (a->attribute == CFI_attribute_other)
+ {
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ /* Adjust the 1-based bounds. */
+ lb = lb - 1;
+ ub = ub - 1;
+ }
+ /* For pointer arrays, the bounds use the same indexing as the lower
+ bound in the array descriptor. */
+
+ /* Make sure we got a valid output descriptor. */
+ if (r->base_addr)
+ abort ();
+ if (r->elem_len != sizeof(int))
+ abort ();
+ if (r->rank != 1)
+ abort ();
+ if (r->type != CFI_type_int)
+ abort ();
+ if (r->attribute != CFI_attribute_pointer)
+ abort ();
+
+ /* Create an array section. */
+ lb_array[0] = lb;
+ ub_array[0] = ub;
+ s_array[0] = s;
+
+ check_CFI_status ("CFI_section",
+ CFI_section (r, a, lb_array, ub_array, s_array));
+
+ /* Check that the output descriptor is correct. */
+ dump_CFI_cdesc_t (r);
+ if (!r->base_addr)
+ abort ();
+ if (r->elem_len != sizeof(int))
+ abort ();
+ if (r->rank != 1)
+ abort ();
+ if (r->type != CFI_type_int)
+ abort ();
+ if (r->attribute != CFI_attribute_pointer)
+ abort ();
+
+ /* Check the contents of the output array. */
+#if 0
+ for (o = r->dim[0].lower_bound, i = lb;
+ (s > 0 ? i <= ub : i >= ub);
+ o++, i += s)
+ {
+ int *input = (int *) CFI_address (a, &i);
+ int *output = (int *) CFI_address (r, &o);
+ fprintf (stderr, "a(%d) = %d, r(%d) = %d\n",
+ (int)i, *input, (int)o, *output);
+ }
+#endif
+ for (o = r->dim[0].lower_bound, i = lb;
+ (s > 0 ? i <= ub : i >= ub);
+ o++, i += s)
+ {
+ int *input = (int *) CFI_address (a, &i);
+ int *output = (int *) CFI_address (r, &o);
+ if (*input != *output)
+ abort ();
+ }
+
+ /* Force the output array to be 1-based. */
+ lb_array[0] = 1;
+ check_CFI_status ("CFI_setpointer", CFI_setpointer (r, r, lb_array));
+ /* Check that the output descriptor is correct. */
+ dump_CFI_cdesc_t (r);
+ if (!r->base_addr)
+ abort ();
+ if (r->elem_len != sizeof(int))
+ abort ();
+ if (r->rank != 1)
+ abort ();
+ if (r->type != CFI_type_int)
+ abort ();
+ if (r->attribute != CFI_attribute_pointer)
+ abort ();
+ if (r->dim[0].lower_bound != 1)
+ abort ();
+
+ /* Check the contents of the output array again. */
+ for (o = r->dim[0].lower_bound, i = lb;
+ (s > 0 ? i <= ub : i >= ub);
+ o++, i += s)
+ {
+ int *input = (int *) CFI_address (a, &i);
+ int *output = (int *) CFI_address (r, &o);
+ if (*input != *output)
+ abort ();
+ }
+
+}
+
+
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/section-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/section-1.f90
new file mode 100644
index 00000000000..4e54116d08c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/section-1.f90
@@ -0,0 +1,71 @@
+! { dg-do run }
+! { dg-additional-sources "section-1-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests basic use of the CFI_section C library function on
+! a 1-dimensional non-pointer/non-allocatable array, passed as an
+! assumed-shape dummy.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest (a, lb, ub, s, r) bind (c)
+ use iso_c_binding
+ integer(C_INT), target :: a(:)
+ integer(C_INT), value :: lb, ub, s
+ integer(C_INT), pointer, intent(out) :: r(:)
+ end subroutine
+
+ end interface
+
+ integer(C_INT), target :: aa(32)
+ integer :: i
+
+ ! Initialize the test array by numbering its elements.
+ do i = 1, 32
+ aa(i) = i
+ end do
+
+ ! Try some cases with non-pointer input arrays.
+ call test (aa, 1, 32, 5, 13, 2) ! basic test
+ call test (aa, 4, 35, 5, 13, 2) ! non-default lower bound
+ call test (aa, 1, 32, 32, 16, -2) ! negative step
+
+contains
+
+ ! Test function for non-pointer array AA.
+ ! LO and HI are the bounds for the entire array.
+ ! LB, UB, and S describe the section to take, and use the
+ ! same indexing as LO and HI.
+ subroutine test (aa, lo, hi, lb, ub, s)
+ integer :: aa(lo:hi)
+ integer :: lo, hi, lb, ub, s
+
+ integer(C_INT), pointer :: rr(:)
+ integer :: i, o
+
+ ! Call the C function to put a section in rr.
+ ! The C function expects the section bounds to be 1-based.
+ nullify (rr)
+ call ctest (aa, lb - lo + 1, ub - lo + 1, s, rr)
+
+ ! Make sure the original array has not been modified.
+ do i = lo, hi
+ if (aa(i) .ne. i - lo + 1) stop 103
+ end do
+
+ ! Make sure the output array has the expected bounds and elements.
+ if (.not. associated (rr)) stop 111
+ if (lbound (rr, 1) .ne. 1) stop 112
+ if (ubound (rr, 1) .ne. (ub - lb)/s + 1) stop 113
+ o = 1
+ do i = lb, ub, s
+ if (rr(o) .ne. i - lo + 1) stop 114
+ o = o + 1
+ end do
+ end subroutine
+
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/section-1p.f90 b/gcc/testsuite/gfortran.dg/c-interop/section-1p.f90
new file mode 100644
index 00000000000..e4831268a1e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/section-1p.f90
@@ -0,0 +1,75 @@
+! PR 101310
+! { dg-do run }
+! { dg-additional-sources "section-1-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests basic use of the CFI_section C library function on
+! a 1-dimensional pointer array.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest (p, lb, ub, s, r) bind (c)
+ use iso_c_binding
+ integer(C_INT), pointer :: p(:)
+ integer(C_INT), value :: lb, ub, s
+ integer(C_INT), pointer, intent(out) :: r(:)
+ end subroutine
+
+ end interface
+
+ integer(C_INT), target :: aa(32)
+ integer :: i
+
+ ! Initialize the test array by numbering its elements.
+ do i = 1, 32
+ aa(i) = i
+ end do
+
+ call test_p (aa, 0, 31, 15, 24, 3) ! zero lower bound
+ call test_p (aa, 1, 32, 16, 25, 3) ! non-zero lower bound
+ call test_p (aa, 4, 35, 16, 25, 3) ! some other lower bound
+ call test_p (aa, 1, 32, 32, 16, -2) ! negative step
+ stop
+
+contains
+
+ ! Test function for non-pointer array AA.
+ ! LO and HI are the bounds for the entire array.
+ ! LB, UB, and S describe the section to take, and use the
+ ! same indexing as LO and HI.
+ subroutine test_p (aa, lo, hi, lb, ub, s)
+ integer, target :: aa(1:hi-lo+1)
+ integer :: lo, hi, lb, ub, s
+
+ integer(C_INT), pointer :: pp(:), rr(:)
+ integer :: i, o
+
+ pp(lo:hi) => aa
+ if (lbound (pp, 1) .ne. lo) stop 121
+ if (ubound (pp, 1) .ne. hi) stop 122
+ nullify (rr)
+ call ctest (pp, lb, ub, s, rr)
+
+ ! Make sure the input pointer array has not been modified.
+ if (lbound (pp, 1) .ne. lo) stop 144
+ if (ubound (pp, 1) .ne. hi) stop 145
+ do i = lo, hi
+ if (pp(i) .ne. i - lo + 1) stop 146
+ end do
+
+ ! Make sure the output array has the expected bounds and elements.
+ if (.not. associated (rr)) stop 151
+ if (lbound (rr, 1) .ne. 1) stop 152
+ if (ubound (rr, 1) .ne. (ub - lb)/s + 1) stop 153
+ o = 1
+ do i = lb, ub, s
+ if (rr(o) .ne. i - lo + 1) stop 154
+ o = o + 1
+ end do
+ end subroutine
+
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/section-2-c.c b/gcc/testsuite/gfortran.dg/c-interop/section-2-c.c
new file mode 100644
index 00000000000..f1ff12715ee
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/section-2-c.c
@@ -0,0 +1,175 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+struct m {
+ int x, y;
+};
+
+extern void ctest (CFI_cdesc_t *a, int lb0, int lb1,
+ int ub0, int ub1, int s0, int s1, CFI_cdesc_t *r);
+
+/* Take a section of array A. OFF is the start index of A on the Fortran
+ side and the bounds LB and UB for the section to take are relative to
+ that base index. Store the result in R, which is supposed to be a pointer
+ array with lower bound 1. */
+
+void
+ctest (CFI_cdesc_t *a, int lb0, int lb1,
+ int ub0, int ub1, int s0, int s1, CFI_cdesc_t *r)
+{
+ CFI_index_t lb_array[2], ub_array[2], s_array[2];
+ int i0, i1, o0, o1;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ fprintf (stderr, "\n%s: lb0=%d lb1=%d ub0=%d ub1=%d s0=%d s1=%d\n",
+ (a->attribute == CFI_attribute_other) ? "non-pointer" : "pointer",
+ lb0, lb1, ub0, ub1, s0, s1);
+ if (lb0 == ub0 || lb1 == ub1)
+ abort ();
+ dump_CFI_cdesc_t (a);
+ dump_CFI_cdesc_t (r);
+
+ /* Make sure we got a valid input descriptor. */
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof(struct m))
+ abort ();
+ if (a->rank != 2)
+ abort ();
+ if (a->type != CFI_type_struct)
+ abort ();
+ if (a->attribute == CFI_attribute_other)
+ {
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ /* Adjust the 1-based bounds. */
+ lb0 = lb0 - 1;
+ lb1 = lb1 - 1;
+ ub0 = ub0 - 1;
+ ub1 = ub1 - 1;
+ }
+ /* For pointer arrays, the bounds use the same indexing as the lower
+ bound in the array descriptor. */
+
+ /* Make sure we got a valid output descriptor. */
+ if (r->base_addr)
+ abort ();
+ if (r->elem_len != sizeof(struct m))
+ abort ();
+ if (r->rank != 2)
+ abort ();
+ if (r->type != CFI_type_struct)
+ abort ();
+ if (r->attribute != CFI_attribute_pointer)
+ abort ();
+
+ /* Create an array section. */
+ lb_array[0] = lb0;
+ lb_array[1] = lb1;
+ ub_array[0] = ub0;
+ ub_array[1] = ub1;
+ s_array[0] = s0;
+ s_array[1] = s1;
+
+ check_CFI_status ("CFI_section",
+ CFI_section (r, a, lb_array, ub_array, s_array));
+
+ /* Check that the output descriptor is correct. */
+ dump_CFI_cdesc_t (r);
+ if (!r->base_addr)
+ abort ();
+ if (r->elem_len != sizeof(struct m))
+ abort ();
+ if (r->rank != 2)
+ abort ();
+ if (r->type != CFI_type_struct)
+ abort ();
+ if (r->attribute != CFI_attribute_pointer)
+ abort ();
+
+ /* Check the contents of the output array. */
+#if 0
+ for (o1 = r->dim[1].lower_bound, i1 = lb1;
+ (s1 > 0 ? i1 <= ub1 : i1 >= ub1);
+ o1++, i1 += s1)
+ for (o0 = r->dim[0].lower_bound, i0 = lb0;
+ (s0 > 0 ? i0 <= ub0 : i0 >= ub0);
+ o0++, i0 += s0)
+ {
+ CFI_index_t index[2];
+ struct m *input, *output;
+ index[0] = i0;
+ index[1] = i1;
+ input = (struct m *) CFI_address (a, index);
+ index[0] = o0;
+ index[1] = o1;
+ output = (struct m *) CFI_address (r, index);
+ fprintf (stderr, "a(%d,%d) = (%d,%d), r(%d,%d) = (%d,%d)\n",
+ i0, i1, input->x, input->y, o0, o1, output->x, output->y);
+ }
+#endif
+ for (o1 = r->dim[1].lower_bound, i1 = lb1;
+ (s1 > 0 ? i1 <= ub1 : i1 >= ub1);
+ o1++, i1 += s1)
+ for (o0 = r->dim[0].lower_bound, i0 = lb0;
+ (s0 > 0 ? i0 <= ub0 : i0 >= ub0);
+ o0++, i0 += s0)
+ {
+ CFI_index_t index[2];
+ struct m *input, *output;
+ index[0] = i0;
+ index[1] = i1;
+ input = (struct m *) CFI_address (a, index);
+ index[0] = o0;
+ index[1] = o1;
+ output = (struct m *) CFI_address (r, index);
+ if (input->x != output->x || input->y != output->y)
+ abort ();
+ }
+
+ /* Force the output array to be 1-based. */
+ lb_array[0] = 1;
+ lb_array[1] = 1;
+ check_CFI_status ("CFI_setpointer", CFI_setpointer (r, r, lb_array));
+ /* Check that the output descriptor is correct. */
+ dump_CFI_cdesc_t (r);
+ if (!r->base_addr)
+ abort ();
+ if (r->elem_len != sizeof(struct m))
+ abort ();
+ if (r->rank != 2)
+ abort ();
+ if (r->type != CFI_type_struct)
+ abort ();
+ if (r->attribute != CFI_attribute_pointer)
+ abort ();
+ if (r->dim[0].lower_bound != 1)
+ abort ();
+
+ /* Check the contents of the output array again. */
+ for (o1 = r->dim[1].lower_bound, i1 = lb1;
+ (s1 > 0 ? i1 <= ub1 : i1 >= ub1);
+ o1++, i1 += s1)
+ for (o0 = r->dim[0].lower_bound, i0 = lb0;
+ (s0 > 0 ? i0 <= ub0 : i0 >= ub0);
+ o0++, i0 += s0)
+ {
+ CFI_index_t index[2];
+ struct m *input, *output;
+ index[0] = i0;
+ index[1] = i1;
+ input = (struct m *) CFI_address (a, index);
+ index[0] = o0;
+ index[1] = o1;
+ output = (struct m *) CFI_address (r, index);
+ if (input->x != output->x || input->y != output->y)
+ abort ();
+ }
+}
+
+
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/section-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/section-2.f90
new file mode 100644
index 00000000000..73ad9ecd3b8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/section-2.f90
@@ -0,0 +1,102 @@
+! { dg-do run }
+! { dg-additional-sources "section-2-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests basic use of the CFI_section C library function on
+! a 2-dimensional non-pointer array.
+
+module mm
+ use ISO_C_BINDING
+ type, bind (c) :: m
+ integer(C_INT) :: x, y
+ end type
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest (a, lb0, lb1, ub0, ub1, s0, s1, r) bind (c)
+ use iso_c_binding
+ use mm
+ type(m), target :: a(:,:)
+ integer(C_INT), value :: lb0, lb1, ub0, ub1, s0, s1
+ type(m), pointer, intent(out) :: r(:,:)
+ end subroutine
+
+ end interface
+
+ type(m), target :: aa(10, 20)
+ integer :: i0, i1
+
+ ! Initialize the test array by numbering its elements.
+ do i1 = 1, 20
+ do i0 = 1, 10
+ aa(i0, i1)%x = i0
+ aa(i0, i1)%y = i1
+ end do
+ end do
+
+ call test (aa, 4, 3, 10, 15, 2, 3) ! basic test
+ call test (aa, 10, 15, 4, 3, -2, -3) ! negative step
+ stop
+
+contains
+
+ ! Test function for non-pointer array AA.
+ ! LB, UB, and S describe the section to take.
+ subroutine test (aa, lb0, lb1, ub0, ub1, s0, s1)
+ use mm
+ type(m) :: aa(10,20)
+ integer :: lb0, lb1, ub0, ub1, s0, s1
+
+ type(m), pointer :: rr(:,:)
+ integer :: i0, i1, o0, o1
+ integer, parameter :: hi0 = 10
+ integer, parameter :: hi1 = 20
+
+ ! Make sure the original array is OK.
+ do i1 = 1, hi1
+ do i0 = 1, hi0
+ if (aa(i0,i1)%x .ne. i0) stop 101
+ if (aa(i0,i1)%y .ne. i1) stop 101
+ end do
+ end do
+
+ ! Call the C function to put a section in rr.
+ ! The C function expects the section bounds to be 1-based.
+ nullify (rr)
+ call ctest (aa, lb0, lb1, ub0, ub1, s0, s1, rr)
+
+ ! Make sure the original array has not been modified.
+ do i1 = 1, hi1
+ do i0 = 1, hi0
+ if (aa(i0,i1)%x .ne. i0) stop 103
+ if (aa(i0,i1)%y .ne. i1) stop 103
+ end do
+ end do
+
+ ! Make sure the output array has the expected bounds and elements.
+ if (.not. associated (rr)) stop 111
+ if (lbound (rr, 1) .ne. 1) stop 112
+ if (lbound (rr, 2) .ne. 1) stop 112
+ if (ubound (rr, 1) .ne. (ub0 - lb0)/s0 + 1) stop 113
+ if (ubound (rr, 2) .ne. (ub1 - lb1)/s1 + 1) stop 113
+ o1 = 1
+ do i1 = lb1, ub1, s1
+ o0 = 1
+ do i0 = lb0, ub0, s0
+ ! print 999, o0, o1, rr(o0,o1)%x, rr(o0,01)%y
+ ! 999 format ('rr(', i3, ',', i3, ') = (', i3, ',', i3, ')')
+ if (rr(o0,o1)%x .ne. i0) stop 114
+ if (rr(o0,o1)%y .ne. i1) stop 114
+ o0 = o0 + 1
+ end do
+ o1 = o1 + 1
+ end do
+ end subroutine
+
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/section-2p.f90 b/gcc/testsuite/gfortran.dg/c-interop/section-2p.f90
new file mode 100644
index 00000000000..f8a174591fa
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/section-2p.f90
@@ -0,0 +1,104 @@
+! PR 101310
+! { dg-do run }
+! { dg-additional-sources "section-2-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests basic use of the CFI_section C library function on
+! a 2-dimensional pointer array.
+
+module mm
+ use ISO_C_BINDING
+ type, bind (c) :: m
+ integer(C_INT) :: x, y
+ end type
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest (p, lb0, lb1, ub0, ub1, s0, s1, r) bind (c)
+ use iso_c_binding
+ use mm
+ type(m), pointer :: p(:,:)
+ integer(C_INT), value :: lb0, lb1, ub0, ub1, s0, s1
+ type(m), pointer, intent(out) :: r(:,:)
+ end subroutine
+
+ end interface
+
+ type(m), target :: aa(10, 20)
+ integer :: i0, i1
+
+ ! Initialize the test array by numbering its elements.
+ do i1 = 1, 20
+ do i0 = 1, 10
+ aa(i0, i1)%x = i0
+ aa(i0, i1)%y = i1
+ end do
+ end do
+
+ call test (aa, 0, 0, 3, 2, 9, 14, 2, 3) ! zero lower bound
+ call test (aa, 1, 1, 4, 3, 10, 15, 2, 3) ! lower bound 1
+ call test (aa, 6, 11, 9, 13, 15, 25, 2, 3) ! other lower bound
+ call test (aa, 1, 1, 10, 15, 4, 3, -2, -3) ! negative step
+ stop
+
+contains
+
+ ! Test function for pointer array AA.
+ ! The bounds of the array are adjusted so it is based at (LO0,LO1).
+ ! LB, UB, and S describe the section of the adjusted array to take.
+ subroutine test (aa, lo0, lo1, lb0, lb1, ub0, ub1, s0, s1)
+ use mm
+ type(m), target :: aa(1:10, 1:20)
+ integer :: lo0, lo1, lb0, lb1, ub0, ub1, s0, s1
+
+ type(m), pointer :: pp(:,:), rr(:,:)
+ integer :: i0, i1, o0, o1
+ integer :: hi0, hi1
+ hi0 = lo0 + 10 - 1
+ hi1 = lo1 + 20 - 1
+
+ pp(lo0:,lo1:) => aa
+ if (lbound (pp, 1) .ne. lo0) stop 121
+ if (lbound (pp, 2) .ne. lo1) stop 121
+ if (ubound (pp, 1) .ne. hi0) stop 122
+ if (ubound (pp, 2) .ne. hi1) stop 122
+ nullify (rr)
+ call ctest (pp, lb0, lb1, ub0, ub1, s0, s1, rr)
+
+ ! Make sure the input pointer array has not been modified.
+ if (lbound (pp, 1) .ne. lo0) stop 131
+ if (ubound (pp, 1) .ne. hi0) stop 132
+ if (lbound (pp, 2) .ne. lo1) stop 133
+ if (ubound (pp, 2) .ne. hi1) stop 134
+ do i1 = lo1, hi1
+ do i0 = lo0, hi0
+ if (pp(i0,i1)%x .ne. i0 - lo0 + 1) stop 135
+ if (pp(i0,i1)%y .ne. i1 - lo1 + 1) stop 136
+ end do
+ end do
+
+ ! Make sure the output array has the expected bounds and elements.
+ if (.not. associated (rr)) stop 141
+ if (lbound (rr, 1) .ne. 1) stop 142
+ if (lbound (rr, 2) .ne. 1) stop 142
+ if (ubound (rr, 1) .ne. (ub0 - lb0)/s0 + 1) stop 143
+ if (ubound (rr, 2) .ne. (ub1 - lb1)/s1 + 1) stop 143
+ o1 = 1
+ do i1 = lb1, ub1, s1
+ o0 = 1
+ do i0 = lb0, ub0, s0
+ if (rr(o0,o1)%x .ne. i0 - lo0 + 1) stop 144
+ if (rr(o0,o1)%y .ne. i1 - lo1 + 1) stop 144
+ o0 = o0 + 1
+ end do
+ o1 = o1 + 1
+ end do
+ end subroutine
+
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/section-3-c.c b/gcc/testsuite/gfortran.dg/c-interop/section-3-c.c
new file mode 100644
index 00000000000..819b58fbe3d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/section-3-c.c
@@ -0,0 +1,235 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+struct m {
+ int x, y;
+};
+
+extern void ctest (CFI_cdesc_t *a, int lb0, int lb1,
+ int ub0, int ub1, int s0, int s1, CFI_cdesc_t *r);
+
+/* Take a section of array A. OFF is the start index of A on the Fortran
+ side and the bounds LB and UB for the section to take are relative to
+ that base index. Store the result in R, which is supposed to be a pointer
+ array with lower bound 1. */
+
+void
+ctest (CFI_cdesc_t *a, int lb0, int lb1,
+ int ub0, int ub1, int s0, int s1, CFI_cdesc_t *r)
+{
+ CFI_index_t lb_array[2], ub_array[2], s_array[2];
+ int i0, i1, o0, o1;
+
+ /* Dump the descriptor contents to test that we can access the fields
+ correctly, etc. */
+ fprintf (stderr, "\n%s: lb0=%d lb1=%d ub0=%d ub1=%d s0=%d s1=%d\n",
+ (a->attribute == CFI_attribute_other) ? "non-pointer" : "pointer",
+ lb0, lb1, ub0, ub1, s0, s1);
+ if (! (lb0 == ub0 || lb1 == ub1))
+ abort ();
+ dump_CFI_cdesc_t (a);
+ dump_CFI_cdesc_t (r);
+
+ /* Make sure we got a valid input descriptor. */
+ if (!a->base_addr)
+ abort ();
+ if (a->elem_len != sizeof(struct m))
+ abort ();
+ if (a->rank != 2)
+ abort ();
+ if (a->type != CFI_type_struct)
+ abort ();
+ if (a->attribute == CFI_attribute_other)
+ {
+ if (a->dim[0].lower_bound != 0)
+ abort ();
+ /* Adjust the 1-based bounds. */
+ lb0 = lb0 - 1;
+ lb1 = lb1 - 1;
+ ub0 = ub0 - 1;
+ ub1 = ub1 - 1;
+ }
+ /* For pointer arrays, the bounds use the same indexing as the lower
+ bound in the array descriptor. */
+
+ /* Make sure we got a valid output descriptor. */
+ if (r->base_addr)
+ abort ();
+ if (r->elem_len != sizeof(struct m))
+ abort ();
+ if (r->rank != 1)
+ abort ();
+ if (r->type != CFI_type_struct)
+ abort ();
+ if (r->attribute != CFI_attribute_pointer)
+ abort ();
+
+ /* Create an array section. */
+ lb_array[0] = lb0;
+ lb_array[1] = lb1;
+ ub_array[0] = ub0;
+ ub_array[1] = ub1;
+ s_array[0] = s0;
+ s_array[1] = s1;
+
+ check_CFI_status ("CFI_section",
+ CFI_section (r, a, lb_array, ub_array, s_array));
+
+ /* Check that the output descriptor is correct. */
+ dump_CFI_cdesc_t (r);
+ if (!r->base_addr)
+ abort ();
+ if (r->elem_len != sizeof(struct m))
+ abort ();
+ if (r->rank != 1)
+ abort ();
+ if (r->type != CFI_type_struct)
+ abort ();
+ if (r->attribute != CFI_attribute_pointer)
+ abort ();
+
+ /* Check the contents of the output array. */
+#if 0
+ if (lb1 == ub1)
+ {
+ /* Output is 1-d array that varies in dimension 0. */
+ for (o0 = r->dim[0].lower_bound, i0 = lb0;
+ (s0 > 0 ? i0 <= ub0 : i0 >= ub0);
+ o0++, i0 += s0)
+ {
+ CFI_index_t index[2];
+ struct m *input, *output;
+ index[0] = i0;
+ index[1] = lb1;
+ input = (struct m *) CFI_address (a, index);
+ index[0] = o0;
+ output = (struct m *) CFI_address (r, index);
+ fprintf (stderr, "a(%d,%d) = (%d,%d), r(%d) = (%d,%d)\n",
+ i0, lb1, input->x, input->y, o0, output->x, output->y);
+ }
+ }
+ else if (lb0 == ub0)
+ {
+ /* Output is 1-d array that varies in dimension 1. */
+ for (o1 = r->dim[0].lower_bound, i1 = lb1;
+ (s1 > 0 ? i1 <= ub1 : i1 >= ub1);
+ o1++, i1 += s1)
+ {
+ CFI_index_t index[2];
+ struct m *input, *output;
+ index[0] = lb0;
+ index[1] = i1;
+ input = (struct m *) CFI_address (a, index);
+ index[0] = o1;
+ output = (struct m *) CFI_address (r, index);
+ fprintf (stderr, "a(%d,%d) = (%d,%d), r(%d) = (%d,%d)\n",
+ lb0, i1, input->x, input->y, o1, output->x, output->y);
+ }
+ }
+ else
+ abort ();
+#endif
+ if (lb1 == ub1)
+ {
+ /* Output is 1-d array that varies in dimension 0. */
+ for (o0 = r->dim[0].lower_bound, i0 = lb0;
+ (s0 > 0 ? i0 <= ub0 : i0 >= ub0);
+ o0++, i0 += s0)
+ {
+ CFI_index_t index[2];
+ struct m *input, *output;
+ index[0] = i0;
+ index[1] = lb1;
+ input = (struct m *) CFI_address (a, index);
+ index[0] = o0;
+ output = (struct m *) CFI_address (r, index);
+ if (input->x != output->x || input->y != output->y)
+ abort ();
+ }
+ }
+ else if (lb0 == ub0)
+ {
+ /* Output is 1-d array that varies in dimension 1. */
+ for (o1 = r->dim[0].lower_bound, i1 = lb1;
+ (s1 > 0 ? i1 <= ub1 : i1 >= ub1);
+ o1++, i1 += s1)
+ {
+ CFI_index_t index[2];
+ struct m *input, *output;
+ index[0] = lb0;
+ index[1] = i1;
+ input = (struct m *) CFI_address (a, index);
+ index[0] = o1;
+ output = (struct m *) CFI_address (r, index);
+ if (input->x != output->x || input->y != output->y)
+ abort ();
+ }
+ }
+ else
+ abort ();
+
+ /* Force the output array to be 1-based. */
+ lb_array[0] = 1;
+ lb_array[1] = 1;
+ check_CFI_status ("CFI_setpointer", CFI_setpointer (r, r, lb_array));
+ /* Check that the output descriptor is correct. */
+ dump_CFI_cdesc_t (r);
+ if (!r->base_addr)
+ abort ();
+ if (r->elem_len != sizeof(struct m))
+ abort ();
+ if (r->rank != 1)
+ abort ();
+ if (r->type != CFI_type_struct)
+ abort ();
+ if (r->attribute != CFI_attribute_pointer)
+ abort ();
+ if (r->dim[0].lower_bound != 1)
+ abort ();
+
+ /* Check the contents of the output array again. */
+ if (lb1 == ub1)
+ {
+ /* Output is 1-d array that varies in dimension 0. */
+ for (o0 = r->dim[0].lower_bound, i0 = lb0;
+ (s0 > 0 ? i0 <= ub0 : i0 >= ub0);
+ o0++, i0 += s0)
+ {
+ CFI_index_t index[2];
+ struct m *input, *output;
+ index[0] = i0;
+ index[1] = lb1;
+ input = (struct m *) CFI_address (a, index);
+ index[0] = o0;
+ output = (struct m *) CFI_address (r, index);
+ if (input->x != output->x || input->y != output->y)
+ abort ();
+ }
+ }
+ else if (lb0 == ub0)
+ {
+ /* Output is 1-d array that varies in dimension 1. */
+ for (o1 = r->dim[0].lower_bound, i1 = lb1;
+ (s1 > 0 ? i1 <= ub1 : i1 >= ub1);
+ o1++, i1 += s1)
+ {
+ CFI_index_t index[2];
+ struct m *input, *output;
+ index[0] = lb0;
+ index[1] = i1;
+ input = (struct m *) CFI_address (a, index);
+ index[0] = o1;
+ output = (struct m *) CFI_address (r, index);
+ if (input->x != output->x || input->y != output->y)
+ abort ();
+ }
+ }
+ else
+ abort ();
+}
+
+
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/section-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/section-3.f90
new file mode 100644
index 00000000000..c690c50b67c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/section-3.f90
@@ -0,0 +1,103 @@
+! PR 101310
+! { dg-do run }
+! { dg-additional-sources "section-3-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests basic use of the CFI_section C library function to
+! take a slice of a 2-dimensional non-pointer array.
+
+module mm
+ use ISO_C_BINDING
+ type, bind (c) :: m
+ integer(C_INT) :: x, y
+ end type
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest (a, lb0, lb1, ub0, ub1, s0, s1, r) bind (c)
+ use iso_c_binding
+ use mm
+ type(m), target :: a(:,:)
+ integer(C_INT), value :: lb0, lb1, ub0, ub1, s0, s1
+ type(m), pointer, intent(out) :: r(:)
+ end subroutine
+
+ end interface
+
+ type(m), target :: aa(10, 20)
+ integer :: i0, i1
+
+ ! Initialize the test array by numbering its elements.
+ do i1 = 1, 20
+ do i0 = 1, 10
+ aa(i0, i1)%x = i0
+ aa(i0, i1)%y = i1
+ end do
+ end do
+
+ call test (aa, 3, 1, 3, 20, 0, 1) ! full slice 0
+ call test (aa, 1, 8, 10, 8, 1, 0) ! full slice 1
+ call test (aa, 3, 5, 3, 14, 0, 3) ! partial slice 0
+ call test (aa, 2, 8, 10, 8, 2, 0) ! partial slice 1
+ call test (aa, 3, 14, 3, 5, 0, -3) ! backwards slice 0
+ call test (aa, 10, 8, 2, 8, -2, 0) ! backwards slice 1
+
+contains
+
+ ! Test function for non-pointer array AA.
+ ! LB, UB, and S describe the section to take.
+ subroutine test (aa, lb0, lb1, ub0, ub1, s0, s1)
+ use mm
+ type(m) :: aa(10,20)
+ integer :: lb0, lb1, ub0, ub1, s0, s1
+
+ type(m), pointer :: rr(:)
+ integer :: i0, i1, o0, o1
+ integer, parameter :: hi0 = 10
+ integer, parameter :: hi1 = 20
+
+ ! Check the bounds actually specify a "slice" rather than a subarray.
+ if (lb0 .ne. ub0 .and. lb1 .ne. ub1) stop 100
+
+ ! Call the C function to put a section in rr.
+ ! The C function expects the section bounds to be 1-based.
+ nullify (rr)
+ call ctest (aa, lb0, lb1, ub0, ub1, s0, s1, rr)
+
+ ! Make sure the original array has not been modified.
+ do i1 = 1, hi1
+ do i0 = 1, hi0
+ if (aa(i0,i1)%x .ne. i0) stop 103
+ if (aa(i0,i1)%y .ne. i1) stop 103
+ end do
+ end do
+
+ ! Make sure the output array has the expected bounds and elements.
+ if (.not. associated (rr)) stop 111
+ if (lbound (rr, 1) .ne. 1) stop 112
+ if (ub0 .eq. lb0) then
+ if (ubound (rr, 1) .ne. (ub1 - lb1)/s1 + 1) stop 113
+ o1 = 1
+ do i1 = lb1, ub1, s1
+ if (rr(o1)%x .ne. lb0) stop 114
+ if (rr(o1)%y .ne. i1) stop 114
+ o1 = o1 + 1
+ end do
+ else
+ if (ubound (rr, 1) .ne. (ub0 - lb0)/s0 + 1) stop 113
+ o0 = 1
+ do i0 = lb0, ub0, s0
+ if (rr(o0)%x .ne. i0) stop 114
+ if (rr(o0)%y .ne. lb1) stop 114
+ o0 = o0 + 1
+ end do
+ end if
+ end subroutine
+
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/section-3p.f90 b/gcc/testsuite/gfortran.dg/c-interop/section-3p.f90
new file mode 100644
index 00000000000..9562b03d992
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/section-3p.f90
@@ -0,0 +1,127 @@
+! PR 101310
+! { dg-do run }
+! { dg-additional-sources "section-3-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests basic use of the CFI_section C library function to
+! take a slice of a 2-dimensional pointer array.
+
+module mm
+ use ISO_C_BINDING
+ type, bind (c) :: m
+ integer(C_INT) :: x, y
+ end type
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+ subroutine ctest (p, lb0, lb1, ub0, ub1, s0, s1, r) bind (c)
+ use iso_c_binding
+ use mm
+ type(m), pointer :: p(:,:)
+ integer(C_INT), value :: lb0, lb1, ub0, ub1, s0, s1
+ type(m), pointer, intent(out) :: r(:)
+ end subroutine
+
+ end interface
+
+ type(m), target :: aa(10, 20)
+ integer :: i0, i1
+
+ ! Initialize the test array by numbering its elements.
+ do i1 = 1, 20
+ do i0 = 1, 10
+ aa(i0, i1)%x = i0
+ aa(i0, i1)%y = i1
+ end do
+ end do
+
+ ! Zero lower bound
+ call test (aa, 0, 0, 2, 0, 2, 19, 0, 1) ! full slice 0
+ call test (aa, 0, 0, 0, 7, 9, 7, 1, 0) ! full slice 1
+ call test (aa, 0, 0, 2, 4, 2, 13, 0, 3) ! partial slice 0
+ call test (aa, 0, 0, 1, 7, 9, 7, 2, 0) ! partial slice 1
+ call test (aa, 0, 0, 2, 13, 2, 4, 0, -3) ! backwards slice 0
+ call test (aa, 0, 0, 9, 7, 1, 7, -2, 0) ! backwards slice 1
+
+ ! Lower bound 1
+ call test (aa, 1, 1, 3, 1, 3, 20, 0, 1) ! full slice 0
+ call test (aa, 1, 1, 1, 8, 10, 8, 1, 0) ! full slice 1
+ call test (aa, 1, 1, 3, 5, 3, 14, 0, 3) ! partial slice 0
+ call test (aa, 1, 1, 2, 8, 10, 8, 2, 0) ! partial slice 1
+ call test (aa, 1, 1, 3, 14, 3, 5, 0, -3) ! backwards slice 0
+ call test (aa, 1, 1, 10, 8, 2, 8, -2, 0) ! backwards slice 1
+
+ ! Some other lower bound
+ call test (aa, 2, 3, 4, 3, 4, 22, 0, 1) ! full slice 0
+ call test (aa, 2, 3, 2, 10, 11, 10, 1, 0) ! full slice 1
+ call test (aa, 2, 3, 4, 7, 4, 16, 0, 3) ! partial slice 0
+ call test (aa, 2, 3, 3, 10, 11, 10, 2, 0) ! partial slice 1
+ call test (aa, 2, 3, 4, 16, 4, 7, 0, -3) ! backwards slice 0
+ call test (aa, 2, 3, 11, 10, 3, 10, -2, 0) ! backwards slice 1
+
+contains
+
+ subroutine test (aa, lo0, lo1, lb0, lb1, ub0, ub1, s0, s1)
+ use mm
+ type(m), target :: aa(10,20)
+ integer :: lo0, lo1, lb0, lb1, ub0, ub1, s0, s1
+
+ type(m), pointer :: pp(:,:), rr(:)
+ integer :: i0, i1, o0, o1
+
+ integer :: hi0, hi1
+ hi0 = lo0 + 10 - 1
+ hi1 = lo1 + 20 - 1
+
+ ! Check the bounds actually specify a "slice" rather than a subarray.
+ if (lb0 .ne. ub0 .and. lb1 .ne. ub1) stop 100
+
+ pp(lo0:,lo1:) => aa
+ if (lbound (pp, 1) .ne. lo0) stop 121
+ if (lbound (pp, 2) .ne. lo1) stop 121
+ if (ubound (pp, 1) .ne. hi0) stop 122
+ if (ubound (pp, 2) .ne. hi1) stop 122
+ nullify (rr)
+ call ctest (pp, lb0, lb1, ub0, ub1, s0, s1, rr)
+
+ ! Make sure the input pointer array has not been modified.
+ if (lbound (pp, 1) .ne. lo0) stop 131
+ if (ubound (pp, 1) .ne. hi0) stop 132
+ if (lbound (pp, 2) .ne. lo1) stop 133
+ if (ubound (pp, 2) .ne. hi1) stop 134
+ do i1 = lo1, hi1
+ do i0 = lo0, hi0
+ if (pp(i0,i1)%x .ne. i0 - lo0 + 1) stop 135
+ if (pp(i0,i1)%y .ne. i1 - lo1 + 1) stop 136
+ end do
+ end do
+
+ ! Make sure the output array has the expected bounds and elements.
+ if (.not. associated (rr)) stop 111
+ if (lbound (rr, 1) .ne. 1) stop 112
+ if (ub0 .eq. lb0) then
+ if (ubound (rr, 1) .ne. (ub1 - lb1)/s1 + 1) stop 113
+ o1 = 1
+ do i1 = lb1, ub1, s1
+ if (rr(o1)%x .ne. lb0 - lo0 + 1) stop 114
+ if (rr(o1)%y .ne. i1 - lo1 + 1) stop 114
+ o1 = o1 + 1
+ end do
+ else
+ if (ubound (rr, 1) .ne. (ub0 - lb0)/s0 + 1) stop 113
+ o0 = 1
+ do i0 = lb0, ub0, s0
+ if (rr(o0)%x .ne. i0 - lo0 + 1) stop 114
+ if (rr(o0)%y .ne. lb1 - lo1 + 1) stop 114
+ o0 = o0 + 1
+ end do
+ end if
+ end subroutine
+
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/section-4-c.c b/gcc/testsuite/gfortran.dg/c-interop/section-4-c.c
new file mode 100644
index 00000000000..07248a5ebfe
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/section-4-c.c
@@ -0,0 +1,101 @@
+#include <stdlib.h>
+#include <stdio.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+struct m {
+ int i, j, k, l;
+};
+
+extern void ctest (void);
+
+#define IMAX 6
+#define JMAX 8
+#define KMAX 10
+#define LMAX 12
+
+static struct m buffer[LMAX][KMAX][JMAX][IMAX];
+
+static void
+check_element (struct m *mp, int i, int j, int k, int l)
+{
+#if 0
+ fprintf (stderr, "expected (%d, %d, %d, %d), got (%d, %d, %d, %d)\n",
+ i, j, k, l, mp->i, mp->j, mp->k, mp->l);
+#endif
+ if (mp->i != i || mp->j != j || mp->k != k || mp->l != l)
+ abort ();
+}
+
+void
+ctest (void)
+{
+ CFI_CDESC_T(4) sdesc;
+ CFI_cdesc_t *source = (CFI_cdesc_t *) &sdesc;
+ CFI_CDESC_T(4) rdesc;
+ CFI_cdesc_t *result = (CFI_cdesc_t *) &rdesc;
+ CFI_index_t extents[4] = { IMAX, JMAX, KMAX, LMAX };
+ CFI_index_t lb[4], ub[4], s[4];
+ int i, j, k, l;
+ int ii, jj, kk, ll;
+
+ /* Initialize the buffer to uniquely label each element. */
+ for (i = 0; i < IMAX; i++)
+ for (j = 0; j < JMAX; j++)
+ for (k = 0; k < KMAX; k++)
+ for (l = 0; l < LMAX; l++)
+ {
+ buffer[l][k][j][i].i = i;
+ buffer[l][k][j][i].j = j;
+ buffer[l][k][j][i].k = k;
+ buffer[l][k][j][i].l = l;
+ }
+
+ /* Establish the source array. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, (void *)buffer,
+ CFI_attribute_pointer, CFI_type_struct,
+ sizeof (struct m), 4, extents));
+
+ /* Try taking a degenerate section (single element). */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL,
+ CFI_attribute_pointer, CFI_type_struct,
+ sizeof (struct m), 0, NULL));
+ lb[0] = 3; lb[1] = 4; lb[2] = 5; lb[3] = 6;
+ ub[0] = 3; ub[1] = 4; ub[2] = 5; ub[3] = 6;
+ s[0] = 0; s[1] = 0; s[2] = 0; s[3] = 0;
+ check_CFI_status ("CFI_section",
+ CFI_section (result, source, lb, ub, s));
+ dump_CFI_cdesc_t (result);
+ check_element ((struct m *)result->base_addr, 3, 4, 5, 6);
+
+ /* Try taking a 2d chunk out of the 4d array. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL,
+ CFI_attribute_pointer, CFI_type_struct,
+ sizeof (struct m), 2, NULL));
+ lb[0] = 1; lb[1] = 2; lb[2] = 3; lb[3] = 4;
+ ub[0] = 1; ub[1] = JMAX - 2; ub[2] = 3; ub[3] = LMAX - 2;
+ s[0] = 0; s[1] = 2; s[2] = 0; s[3] = 3;
+ check_CFI_status ("CFI_section",
+ CFI_section (result, source, lb, ub, s));
+ dump_CFI_cdesc_t (result);
+
+ i = lb[0];
+ k = lb[2];
+ for (j = lb[1], jj = result->dim[0].lower_bound;
+ j <= ub[1];
+ j += s[1], jj++)
+ for (l = lb[3], ll = result->dim[1].lower_bound;
+ l <= ub[3];
+ l += s[3], ll++)
+ {
+ CFI_index_t subscripts[2];
+ subscripts[0] = jj;
+ subscripts[1] = ll;
+ check_element ((struct m *) CFI_address (result, subscripts),
+ i, j, k, l);
+ }
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/section-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/section-4.f90
new file mode 100644
index 00000000000..2300e6184f9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/section-4.f90
@@ -0,0 +1,23 @@
+! PR 101310
+! { dg-do run }
+! { dg-additional-sources "section-4-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests various scenarios with using CFI_section to extract
+! a section with rank less than the source array. Everything interesting
+! happens on the C side.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest () bind (c)
+ use iso_c_binding
+ end subroutine
+
+ end interface
+
+ call ctest ()
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/section-errors-c.c b/gcc/testsuite/gfortran.dg/c-interop/section-errors-c.c
new file mode 100644
index 00000000000..67be7d52121
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/section-errors-c.c
@@ -0,0 +1,149 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+/* For simplicity, point descriptors at a static buffer. */
+#define BUFSIZE 256
+static char *buf[BUFSIZE] __attribute__ ((aligned (8)));
+static CFI_index_t extents[] = {10};
+
+/* External entry point. The arguments are descriptors for input arrays;
+ we'll construct new descriptors for the outputs of CFI_section. */
+extern void ctest (void);
+
+void
+ctest (void)
+{
+ int bad = 0;
+ int status;
+ CFI_CDESC_T(1) sdesc;
+ CFI_cdesc_t *source = (CFI_cdesc_t *) &sdesc;
+ CFI_CDESC_T(3) rdesc;
+ CFI_cdesc_t *result = (CFI_cdesc_t *) &rdesc;
+ CFI_index_t lb = 2;
+ CFI_index_t ub = 8;
+ CFI_index_t step = 2;
+ CFI_index_t zstep = 0;
+
+ /* Use a 1-d integer source array for the first few tests. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, (void *)buf, CFI_attribute_other,
+ CFI_type_int, 0, 1, extents));
+
+ /* result shall be the address of a C descriptor with rank equal
+ to the rank of source minus the number of zero strides. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_int, 0, 0, NULL));
+ status = CFI_section (result, source, &lb, &ub, &step);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for rank mismatch (too small)\n");
+ bad ++;
+ }
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_int, 0, 1, NULL));
+ status = CFI_section (result, source, &lb, &lb, &zstep);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for rank mismatch (zero stride)\n");
+ bad ++;
+ }
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_int, 0, 3, NULL));
+ status = CFI_section (result, source, &lb, &ub, &step);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for rank mismatch (too large)\n");
+ bad ++;
+ }
+
+ /* The attribute member [of result] shall have the value
+ CFI_attribute_other or CFI_attribute_pointer. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_allocatable,
+ CFI_type_int, 0, 1, NULL));
+ status = CFI_section (result, source, &lb, &ub, &step);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for CFI_attribute_allocatable result\n");
+ bad ++;
+ }
+
+ /* source shall be the address of a C descriptor that describes a
+ nonallocatable nonpointer array, an allocated allocatable array,
+ or an associated array pointer. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, NULL, CFI_attribute_allocatable,
+ CFI_type_int, 0, 1, NULL));
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_int, 0, 1, NULL));
+ status = CFI_section (result, source, &lb, &ub, &step);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for unallocated allocatable source array\n");
+ bad ++;
+ }
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, NULL, CFI_attribute_pointer,
+ CFI_type_int, 0, 1, NULL));
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_int, 0, 1, NULL));
+ status = CFI_section (result, source, &lb, &ub, &step);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for unassociated pointer source array\n");
+ bad ++;
+ }
+
+ /* The corresponding values of the elem_len and type members shall
+ be the same in the C descriptors with the addresses source
+ and result. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, (void *)buf, CFI_attribute_other,
+ CFI_type_struct,
+ sizeof(int), 1, extents));
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_struct,
+ 2*sizeof (int), 1, NULL));
+ status = CFI_section (result, source, &lb, &ub, &step);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for elem_len mismatch\n");
+ bad ++;
+ }
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_int, 0, 1, NULL));
+ status = CFI_section (result, source, &lb, &ub, &step);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for type mismatch\n");
+ bad ++;
+ }
+
+ if (bad)
+ abort ();
+}
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/section-errors.f90 b/gcc/testsuite/gfortran.dg/c-interop/section-errors.f90
new file mode 100644
index 00000000000..28328b799b3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/section-errors.f90
@@ -0,0 +1,27 @@
+! { dg-do run }
+! { dg-additional-sources "section-errors-c.c dump-descriptors.c" }
+! { dg-additional-options "-Wno-error -fcheck=all" }
+! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 }
+!
+! This program tests that the CFI_section function properly detects
+! invalid arguments. All the interesting things happen in the
+! corresponding C code.
+!
+! The situation here seems to be that while TS29113 defines error codes
+! for CFI_section, it doesn't actually require the implementation to detect
+! those errors by saying the arguments "shall be" such-and-such, e.g. it is
+! undefined behavior if they are not. In gfortran you can enable some
+! run-time checking by building with -fcheck=all.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest () bind (c)
+ end subroutine
+ end interface
+
+ call ctest ()
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/select-c.c b/gcc/testsuite/gfortran.dg/c-interop/select-c.c
new file mode 100644
index 00000000000..663ac0d34b3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/select-c.c
@@ -0,0 +1,138 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+/* Declare some source arrays. */
+struct ss {
+ char c[4];
+ signed char b[4];
+ int i, j, k;
+} s[10][5][3];
+
+char c[10][16];
+
+double _Complex dc[10];
+
+CFI_index_t extents3[] = {3,5,10};
+CFI_index_t extents1[] = {10};
+
+/* External entry point. */
+extern void ctest (void);
+
+void
+ctest (void)
+{
+ CFI_CDESC_T(3) sdesc;
+ CFI_cdesc_t *source = (CFI_cdesc_t *) &sdesc;
+ CFI_CDESC_T(3) rdesc;
+ CFI_cdesc_t *result = (CFI_cdesc_t *) &rdesc;
+ size_t offset;
+
+ /* Extract an array of structure elements. */
+ offset = offsetof (struct ss, j);
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, (void *)s, CFI_attribute_other,
+ CFI_type_struct,
+ sizeof (struct ss), 3, extents3));
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_int, 0, 3, NULL));
+ check_CFI_status ("CFI_select_part",
+ CFI_select_part (result, source, offset, 0));
+ dump_CFI_cdesc_t (source);
+ dump_CFI_cdesc_t (result);
+
+ if (result->elem_len != sizeof (int))
+ abort ();
+ if (result->base_addr != source->base_addr + offset)
+ abort ();
+ if (result->dim[0].extent != source->dim[0].extent)
+ abort ();
+ if (result->dim[0].sm != source->dim[0].sm)
+ abort ();
+ if (result->dim[1].extent != source->dim[1].extent)
+ abort ();
+ if (result->dim[1].sm != source->dim[1].sm)
+ abort ();
+ if (result->dim[2].extent != source->dim[2].extent)
+ abort ();
+ if (result->dim[2].sm != source->dim[2].sm)
+ abort ();
+
+ /* Check that we use the given elem_size for char but not for
+ signed char, which is considered an integer type instead of a Fortran
+ character type. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_char, 4, 3, NULL));
+ if (result->elem_len != 4)
+ abort ();
+ offset = offsetof (struct ss, c);
+ check_CFI_status ("CFI_select_part",
+ CFI_select_part (result, source, offset, 4));
+ if (result->elem_len != 4)
+ abort ();
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_signed_char, 4, 3, NULL));
+ if (result->elem_len != sizeof (signed char))
+ abort ();
+ offset = offsetof (struct ss, c);
+ check_CFI_status ("CFI_select_part",
+ CFI_select_part (result, source, offset, 4));
+ if (result->elem_len != sizeof (signed char))
+ abort ();
+
+ /* Extract an array of character substrings. */
+ offset = 2;
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, (void *)c, CFI_attribute_other,
+ CFI_type_char, 16, 1, extents1));
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_char, 8, 1, NULL));
+ check_CFI_status ("CFI_select_part",
+ CFI_select_part (result, source, offset, 8));
+ dump_CFI_cdesc_t (source);
+ dump_CFI_cdesc_t (result);
+
+ if (result->elem_len != 8)
+ abort ();
+ if (result->base_addr != source->base_addr + offset)
+ abort ();
+ if (result->dim[0].extent != source->dim[0].extent)
+ abort ();
+ if (result->dim[0].sm != source->dim[0].sm)
+ abort ();
+
+ /* Extract an array the imaginary parts of complex numbers.
+ Note that the use of __imag__ to obtain the imaginary part as
+ an lvalue is a GCC extension. */
+ offset = (void *)&(__imag__ dc[0]) - (void *)&(dc[0]);
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, (void *)dc, CFI_attribute_other,
+ CFI_type_double_Complex,
+ 0, 1, extents1));
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_double, 0, 1, NULL));
+ check_CFI_status ("CFI_select_part",
+ CFI_select_part (result, source, offset, 0));
+ dump_CFI_cdesc_t (source);
+ dump_CFI_cdesc_t (result);
+
+ if (result->elem_len != sizeof (double))
+ abort ();
+ if (result->base_addr != source->base_addr + offset)
+ abort ();
+ if (result->dim[0].extent != source->dim[0].extent)
+ abort ();
+ if (result->dim[0].sm != source->dim[0].sm)
+ abort ();
+}
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/select-errors-c.c b/gcc/testsuite/gfortran.dg/c-interop/select-errors-c.c
new file mode 100644
index 00000000000..7eb815ea31b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/select-errors-c.c
@@ -0,0 +1,125 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+/* Source is an array of structs. */
+struct ss {
+ int i, j;
+ char c[16];
+ double _Complex dc;
+} s[10];
+
+CFI_index_t extents[] = {10};
+
+/* External entry point. */
+extern void ctest (void);
+
+void
+ctest (void)
+{
+ int bad = 0;
+ int status;
+ CFI_CDESC_T(1) sdesc;
+ CFI_cdesc_t *source = (CFI_cdesc_t *) &sdesc;
+ CFI_CDESC_T(3) rdesc;
+ CFI_cdesc_t *result = (CFI_cdesc_t *) &rdesc;
+
+ /* Create a descriptor for the source array. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, (void *)s, CFI_attribute_other,
+ CFI_type_struct,
+ sizeof (struct ss), 1, extents));
+
+ /* The attribute member of result shall have the value
+ CFI_attribute_other or CFI_attribute_pointer. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_allocatable,
+ CFI_type_int, 0, 1, NULL));
+ status = CFI_select_part (result, source, offsetof (struct ss, j), 0);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for CFI_attribute_allocatable result\n");
+ bad ++;
+ }
+
+ /* The rank member of the result C descriptor shall have the same value
+ as the rank member of the C descriptor at the address specified
+ by source. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_int, 0, 0, NULL));
+ status = CFI_select_part (result, source, offsetof (struct ss, j), 0);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for rank mismatch (too small)\n");
+ bad ++;
+ }
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_int, 0, 3, NULL));
+ status = CFI_select_part (result, source, offsetof (struct ss, j), 0);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for rank mismatch (too large)\n");
+ bad ++;
+ }
+
+ /* The value of displacement shall be between 0 and source->elem_len - 1
+ inclusive. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_int, 0, 1, NULL));
+ status = CFI_select_part (result, source, -8, 0);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for negative displacement\n");
+ bad ++;
+ }
+ status = CFI_select_part (result, source, source->elem_len, 0);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for too-large displacement\n");
+ bad ++;
+ }
+
+ /* source shall be the address of a C descriptor for a nonallocatable
+ nonpointer array, an allocated allocatable array, or an associated
+ array pointer. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, NULL, CFI_attribute_allocatable,
+ CFI_type_struct,
+ sizeof (struct ss), 1, NULL));
+ status = CFI_select_part (result, source, offsetof (struct ss, j), 0);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for unallocated allocatable source array\n");
+ bad ++;
+ }
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, NULL, CFI_attribute_pointer,
+ CFI_type_struct,
+ sizeof (struct ss), 1, NULL));
+ status = CFI_select_part (result, source, offsetof (struct ss, j), 0);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for unassociated pointer source array\n");
+ bad ++;
+ }
+
+ if (bad)
+ abort ();
+}
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/select-errors.f90 b/gcc/testsuite/gfortran.dg/c-interop/select-errors.f90
new file mode 100644
index 00000000000..b719c9e6867
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/select-errors.f90
@@ -0,0 +1,27 @@
+! { dg-do run }
+! { dg-additional-sources "select-errors-c.c dump-descriptors.c" }
+! { dg-additional-options "-Wno-error -fcheck=all" }
+! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 }
+!
+! This program tests that the CFI_select_part function properly detects
+! invalid arguments. All the interesting things happen in the
+! corresponding C code.
+!
+! The situation here seems to be that while TS29113 defines error codes for
+! CFI_select_part, it doesn't actually require the implementation to detect
+! those errors by saying the arguments "shall be" such-and-such, e.g. it is
+! undefined behavior if they are not. In gfortran you can enable some
+! run-time checking by building with -fcheck=all.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest () bind (c)
+ end subroutine
+ end interface
+
+ call ctest ()
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/select.f90 b/gcc/testsuite/gfortran.dg/c-interop/select.f90
new file mode 100644
index 00000000000..133385e3c1f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/select.f90
@@ -0,0 +1,18 @@
+! { dg-do run }
+! { dg-additional-sources "select-c.c dump-descriptors.c" }
+!
+! This program tests the CFI_select_part function. All the interesting
+! things happen in the corresponding C code.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest () bind (c)
+ end subroutine
+ end interface
+
+ call ctest ()
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/setpointer-c.c b/gcc/testsuite/gfortran.dg/c-interop/setpointer-c.c
new file mode 100644
index 00000000000..249cb2bcd87
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/setpointer-c.c
@@ -0,0 +1,78 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+static int a[10][5][3];
+static CFI_index_t extents[] = {3, 5, 10};
+static CFI_index_t lb1[] = {1, 2, 3};
+static CFI_index_t lb2[] = {0, 1, -10};
+
+/* External entry point. */
+extern void ctest (void);
+
+void
+ctest (void)
+{
+ CFI_CDESC_T(3) sdesc;
+ CFI_cdesc_t *source = (CFI_cdesc_t *) &sdesc;
+ CFI_CDESC_T(3) rdesc;
+ CFI_cdesc_t *result = (CFI_cdesc_t *) &rdesc;
+
+ /* Create descriptors. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, (void *)a, CFI_attribute_pointer,
+ CFI_type_int, 0, 3, extents));
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_int, 0, 3, NULL));
+
+ /* Use setpointer to adjust the bounds of source in place. */
+ check_CFI_status ("CFI_setpointer",
+ CFI_setpointer (source, source, lb1));
+ dump_CFI_cdesc_t (source);
+ if (source->dim[0].lower_bound != lb1[0])
+ abort ();
+ if (source->dim[1].lower_bound != lb1[1])
+ abort ();
+ if (source->dim[2].lower_bound != lb1[2])
+ abort ();
+
+ /* Use setpointer to copy the pointer and bounds from source. */
+ check_CFI_status ("CFI_setpointer",
+ CFI_setpointer (result, source, NULL));
+ dump_CFI_cdesc_t (result);
+ if (result->base_addr != source->base_addr)
+ abort ();
+ if (result->dim[0].lower_bound != source->dim[0].lower_bound)
+ abort ();
+ if (result->dim[1].lower_bound != source->dim[1].lower_bound)
+ abort ();
+ if (result->dim[2].lower_bound != source->dim[2].lower_bound)
+ abort ();
+
+ /* Use setpointer to nullify result. */
+ check_CFI_status ("CFI_setpointer",
+ CFI_setpointer (result, NULL, NULL));
+ dump_CFI_cdesc_t (result);
+ if (result->base_addr)
+ abort ();
+
+ /* Use setpointer to copy the pointer from source, but use
+ different bounds. */
+ check_CFI_status ("CFI_setpointer",
+ CFI_setpointer (result, source, lb2));
+ dump_CFI_cdesc_t (source);
+ if (result->base_addr != source->base_addr)
+ abort ();
+ if (result->dim[0].lower_bound != lb2[0])
+ abort ();
+ if (result->dim[1].lower_bound != lb2[1])
+ abort ();
+ if (result->dim[2].lower_bound != lb2[2])
+ abort ();
+}
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/setpointer-errors-c.c b/gcc/testsuite/gfortran.dg/c-interop/setpointer-errors-c.c
new file mode 100644
index 00000000000..7931e1ebf51
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/setpointer-errors-c.c
@@ -0,0 +1,127 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+static int a[10][5][3];
+static CFI_index_t extents[] = {3, 5, 10};
+
+/* External entry point. */
+extern void ctest (void);
+
+void
+ctest (void)
+{
+ int bad = 0;
+ int status;
+ CFI_CDESC_T(3) sdesc;
+ CFI_cdesc_t *source = (CFI_cdesc_t *) &sdesc;
+ CFI_CDESC_T(3) rdesc;
+ CFI_cdesc_t *result = (CFI_cdesc_t *) &rdesc;
+
+ /* result shall be the address of a C descriptor for a Fortran pointer. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, (void *)a, CFI_attribute_other,
+ CFI_type_int, 0, 3, extents));
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_allocatable,
+ CFI_type_int, 0, 3, NULL));
+ status = CFI_setpointer (result, source, NULL);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for CFI_attribute_allocatable result\n");
+ bad ++;
+ }
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_other,
+ CFI_type_int, 0, 3, NULL));
+ status = CFI_setpointer (result, source, NULL);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for CFI_attribute_other result\n");
+ bad ++;
+ }
+
+ /* source shall be a null pointer or the address of a C descriptor
+ for an allocated allocatable object, a data pointer object, or a
+ nonallocatable nonpointer data object that is not an
+ assumed-size array. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_int, 0, 3, NULL));
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, NULL, CFI_attribute_allocatable,
+ CFI_type_int, 0, 3, NULL));
+ status = CFI_setpointer (result, source, NULL);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for unallocated allocatable source\n");
+ bad ++;
+ }
+
+ /* CFI_establish rejects negative extents, so we can't use it to make
+ an assumed-size array, so hack the descriptor by hand. Yuck. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, (void *)a, CFI_attribute_other,
+ CFI_type_int, 0, 3, extents));
+ source->dim[2].extent = -1;
+ status = CFI_setpointer (result, source, NULL);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for assumed-size source array\n");
+ bad ++;
+ }
+
+ /* If source is not a null pointer, the corresponding values of the
+ elem_len, rank, and type members shall be the same in the C
+ descriptors with the addresses source and result. */
+ check_CFI_status ("CFI_establish",
+ CFI_establish (source, (void *)a, CFI_attribute_other,
+ CFI_type_char, sizeof(int), 3, extents));
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_char, 1, 3, NULL));
+ status = CFI_setpointer (result, source, NULL);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for elem_len mismatch\n");
+ bad ++;
+ }
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_char, sizeof(int), 1, NULL));
+ status = CFI_setpointer (result, source, NULL);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for rank mismatch\n");
+ bad ++;
+ }
+
+ check_CFI_status ("CFI_establish",
+ CFI_establish (result, NULL, CFI_attribute_pointer,
+ CFI_type_int, 0, 3, NULL));
+ status = CFI_setpointer (result, source, NULL);
+ if (status == CFI_SUCCESS)
+ {
+ fprintf (stderr,
+ "no error for type mismatch\n");
+ bad ++;
+ }
+
+ if (bad)
+ abort ();
+}
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/setpointer-errors.f90 b/gcc/testsuite/gfortran.dg/c-interop/setpointer-errors.f90
new file mode 100644
index 00000000000..84a01ce16b1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/setpointer-errors.f90
@@ -0,0 +1,28 @@
+! PR 101317
+! { dg-do run }
+! { dg-additional-sources "setpointer-errors-c.c dump-descriptors.c" }
+! { dg-additional-options "-Wno-error -fcheck=all" }
+! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 }
+!
+! This program tests that the CFI_setpointer function properly detects
+! invalid arguments. All the interesting things happen in the
+! corresponding C code.
+!
+! The situation here seems to be that while TS29113 defines error codes for
+! CFI_setpointer, it doesn't actually require the implementation to detect
+! those errors by saying the arguments "shall be" such-and-such, e.g. it is
+! undefined behavior if they are not. In gfortran you can enable some
+! run-time checking by building with -fcheck=all.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest () bind (c)
+ end subroutine
+ end interface
+
+ call ctest ()
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/setpointer.f90 b/gcc/testsuite/gfortran.dg/c-interop/setpointer.f90
new file mode 100644
index 00000000000..57ef183df32
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/setpointer.f90
@@ -0,0 +1,18 @@
+! { dg-do run }
+! { dg-additional-sources "setpointer-c.c dump-descriptors.c" }
+!
+! This program tests the CFI_setpointer function. All the interesting
+! things happen in the corresponding C code.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+ subroutine ctest () bind (c)
+ end subroutine
+ end interface
+
+ call ctest ()
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/shape.f90 b/gcc/testsuite/gfortran.dg/c-interop/shape.f90
new file mode 100644
index 00000000000..dd790bbca90
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/shape.f90
@@ -0,0 +1,77 @@
+! { dg-do run }
+!
+! TS 29113
+! 6.4.1 SHAPE
+!
+! The description of the intrinsic function SHAPE in ISO/IEC 1539-1:2010
+! is changed for an assumed-rank array that is associated with an
+! assumed-size array; an assumed-size array has no shape, but in this
+! case the result has a value equal to
+! [ (SIZE (ARRAY, I, KIND), I=1,RANK (ARRAY)) ]
+! with KIND omitted from SIZE if it was omitted from SHAPE.
+!
+! The idea here is that the main program passes some arrays to a test
+! subroutine with an assumed-size dummy, which in turn passes that to a
+! subroutine with an assumed-rank dummy.
+
+program test
+
+ ! Define some arrays for testing.
+ integer, target :: x1(5)
+ integer :: y1(0:9)
+ integer, pointer :: p1(:)
+ integer, allocatable :: a1(:)
+ integer, target :: x3(2,3,4)
+ integer :: y3(0:1,-3:-1,4)
+ integer, pointer :: p3(:,:,:)
+ integer, allocatable :: a3(:,:,:)
+
+ ! Test the 1-dimensional arrays.
+ call test1 (x1)
+ call test1 (y1)
+ p1 => x1
+ call test1 (p1)
+ allocate (a1(5))
+ call test1 (a1)
+
+ ! Test the multi-dimensional arrays.
+ call test3 (x3, 1, 2, 1, 3)
+ call test3 (y3, 0, 1, -3, -1)
+ p3 => x3
+ call test3 (p3, 1, 2, 1, 3)
+ allocate (a3(2,3,4))
+ call test3 (a3, 1, 2, 1, 3)
+
+contains
+
+ subroutine testit (a)
+ integer :: a(..)
+
+ integer :: r
+ r = rank(a)
+
+ block
+ integer :: s(r)
+ s = shape(a)
+ do i = 1, r
+ if (s(i) .ne. size(a,i)) stop 101
+ end do
+ end block
+
+ end subroutine
+
+ subroutine test1 (a)
+ integer :: a(*)
+
+ call testit (a)
+ end subroutine
+
+ subroutine test3 (a, l1, u1, l2, u2)
+ implicit none
+ integer :: l1, u1, l2, u2
+ integer :: a(l1:u1, l2:u2, *)
+
+ call testit (a)
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/size.f90 b/gcc/testsuite/gfortran.dg/c-interop/size.f90
new file mode 100644
index 00000000000..6c6699701bf
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/size.f90
@@ -0,0 +1,106 @@
+! Reported as pr94070.
+! { dg-do run { xfail *-*-* } }
+!
+! TS 29113
+! 6.4.2 SIZE
+!
+! The description of the intrinsic function SIZE in ISO/IEC 1539-1:2010
+! is changed in the following cases:
+!
+! (1) for an assumed-rank object that is associated with an assumed-size
+! array, the result has the value −1 if DIM is present and equal to the
+! rank of ARRAY, and a negative value that is equal to
+! PRODUCT ( [ (SIZE (ARRAY, I, KIND), I=1, RANK (ARRAY)) ] )
+! if DIM is not present;
+!
+! (2) for an assumed-rank object that is associated with a scalar, the
+! result has the value 1.
+!
+! The idea here is that the main program passes some arrays to a test
+! subroutine with an assumed-size dummy, which in turn passes that to a
+! subroutine with an assumed-rank dummy.
+
+program test
+
+ ! Define some arrays for testing.
+ integer, target :: x1(5)
+ integer :: y1(0:9)
+ integer, pointer :: p1(:)
+ integer, allocatable :: a1(:)
+ integer, target :: x3(2,3,4)
+ integer :: y3(0:1,-3:-1,4)
+ integer, pointer :: p3(:,:,:)
+ integer, allocatable :: a3(:,:,:)
+ integer :: x
+
+ ! Test the 1-dimensional arrays.
+ call test1 (x1)
+ call test1 (y1)
+ p1 => x1
+ call test1 (p1)
+ allocate (a1(5))
+ call test1 (a1)
+
+ ! Test the multi-dimensional arrays.
+ call test3 (x3, 1, 2, 1, 3)
+ call test3 (y3, 0, 1, -3, -1)
+ p3 => x3
+ call test3 (p3, 1, 2, 1, 3)
+ allocate (a3(2,3,4))
+ call test3 (a3, 1, 2, 1, 3)
+
+ ! Test scalars.
+ call test0 (x)
+ call test0 (-1)
+ call test0 (x1(1))
+
+contains
+
+ subroutine testit (a, r, sizes)
+ integer :: a(..)
+ integer :: r
+ integer :: sizes(r)
+
+ integer :: totalsize, thissize
+ totalsize = 1
+
+ if (r .ne. rank(a)) stop 101
+
+ do i = 1, r
+ thissize = size (a, i)
+ print *, 'got size ', thissize, ' expected ', sizes(i)
+ if (thissize .ne. sizes(i)) stop 102
+ totalsize = totalsize * thissize
+ end do
+
+ if (size(a) .ne. totalsize) stop 103
+ end subroutine
+
+ subroutine test0 (a)
+ integer :: a(..)
+
+ if (size (a) .ne. 1) stop 103
+ end subroutine
+
+ subroutine test1 (a)
+ integer :: a(*)
+
+ integer :: sizes(1)
+ sizes(1) = -1
+ call testit (a, 1, sizes)
+ end subroutine
+
+ subroutine test3 (a, l1, u1, l2, u2)
+ implicit none
+ integer :: l1, u1, l2, u2
+ integer :: a(l1:u1, l2:u2, *)
+
+ integer :: sizes(3)
+ sizes(1) = u1 - l1 + 1
+ sizes(2) = u2 - l2 + 1
+ sizes(3) = -1
+
+ call testit (a, 3, sizes)
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/tkr.f90 b/gcc/testsuite/gfortran.dg/c-interop/tkr.f90
new file mode 100644
index 00000000000..c0c0d7e86f8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/tkr.f90
@@ -0,0 +1,46 @@
+! { dg-do compile}
+!
+! TS 29113
+! The definition of TKR compatible in paragraph 2 of subclause 12.4.3.4.5
+! of ISO/IEC 1539-1:2010 is changed to:
+!
+! A dummy argument is type, kind, and rank compatible, or TKR compatible,
+! with another dummy argument if the first is type compatible with the
+! second, the kind type parameters of the first have the same values as
+! the corresponding kind type parameters of the second, and both have the
+! same rank or either is assumed-rank.
+!
+! This test file contains tests that are expected to issue diagnostics
+! for invalid code.
+
+module m
+
+interface foo
+ subroutine foo_1 (x) ! { dg-error "Ambiguous interfaces" }
+ integer :: x(..)
+ end subroutine
+ subroutine foo_2 (x) ! { dg-error "Ambiguous interfaces" }
+ integer :: x(:, :)
+ end subroutine
+end interface
+
+interface bar
+ subroutine bar_1 (x) ! { dg-error "Ambiguous interfaces" }
+ integer :: x(..)
+ end subroutine
+ subroutine bar_2 (x) ! { dg-error "Ambiguous interfaces" }
+ integer :: x(..)
+ end subroutine
+end interface
+
+interface baz
+ subroutine baz_1 (x) ! { dg-error "Ambiguous interfaces" }
+ integer :: x
+ end subroutine
+ subroutine baz_2 (x) ! { dg-error "Ambiguous interfaces" }
+ integer :: x(..)
+ end subroutine
+end interface
+
+end module
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-basic-c.c b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-basic-c.c
new file mode 100644
index 00000000000..34bf218b2b2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-basic-c.c
@@ -0,0 +1,169 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest_int1 (CFI_cdesc_t *arg_int,
+ CFI_cdesc_t *arg_short,
+ CFI_cdesc_t *arg_long,
+ CFI_cdesc_t *arg_long_long,
+ CFI_cdesc_t *arg_signed_char);
+
+extern void ctest_int2 (CFI_cdesc_t *arg_int8,
+ CFI_cdesc_t *arg_int16,
+ CFI_cdesc_t *arg_int32,
+ CFI_cdesc_t *arg_int64);
+
+extern void ctest_int3 (CFI_cdesc_t *arg_least8,
+ CFI_cdesc_t *arg_least16,
+ CFI_cdesc_t *arg_least32,
+ CFI_cdesc_t *arg_least64);
+
+extern void ctest_int4 (CFI_cdesc_t *arg_fast8,
+ CFI_cdesc_t *arg_fast16,
+ CFI_cdesc_t *arg_fast32,
+ CFI_cdesc_t *arg_fast64);
+
+extern void ctest_int5 (CFI_cdesc_t *arg_size,
+ CFI_cdesc_t *arg_intmax,
+ CFI_cdesc_t *arg_intptr,
+ CFI_cdesc_t *arg_ptrdiff);
+
+extern void ctest_real (CFI_cdesc_t *arg_float,
+ CFI_cdesc_t *arg_double);
+
+extern void ctest_complex (CFI_cdesc_t *arg_float_complex,
+ CFI_cdesc_t *arg_double_complex);
+
+extern void ctest_misc (CFI_cdesc_t *arg_bool,
+ CFI_cdesc_t *arg_cptr,
+ CFI_cdesc_t *arg_cfunptr,
+ CFI_cdesc_t *arg_struct);
+
+/* Sanity check the type info in the descriptor a. */
+
+static void
+check (CFI_cdesc_t *a, size_t size, int typecode)
+{
+ dump_CFI_cdesc_t (a);
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->base_addr == NULL)
+ abort ();
+ if (a->rank != 1)
+ abort ();
+ if (size && a->elem_len != size)
+ abort ();
+ if (a->type != typecode)
+ abort ();
+}
+
+
+/* Test that the basic integer types correspond correctly. */
+void
+ctest_int1 (CFI_cdesc_t *arg_int,
+ CFI_cdesc_t *arg_short,
+ CFI_cdesc_t *arg_long,
+ CFI_cdesc_t *arg_long_long,
+ CFI_cdesc_t *arg_signed_char)
+{
+ check (arg_int, sizeof (int), CFI_type_int);
+ check (arg_short, sizeof (short), CFI_type_short);
+ check (arg_long, sizeof (long), CFI_type_long);
+ check (arg_long_long, sizeof (long long int), CFI_type_long_long);
+ check (arg_signed_char, sizeof (signed char), CFI_type_signed_char);
+}
+
+/* Test the integer types of explicit sizes. */
+void
+ctest_int2 (CFI_cdesc_t *arg_int8,
+ CFI_cdesc_t *arg_int16,
+ CFI_cdesc_t *arg_int32,
+ CFI_cdesc_t *arg_int64)
+{
+ check (arg_int8, sizeof (int8_t), CFI_type_int8_t);
+ check (arg_int16, sizeof (int16_t), CFI_type_int16_t);
+ check (arg_int32, sizeof (int32_t), CFI_type_int32_t);
+ check (arg_int64, sizeof (int64_t), CFI_type_int64_t);
+}
+
+/* Check the int_least*_t types. */
+
+void
+ctest_int3 (CFI_cdesc_t *arg_least8,
+ CFI_cdesc_t *arg_least16,
+ CFI_cdesc_t *arg_least32,
+ CFI_cdesc_t *arg_least64)
+{
+ check (arg_least8, sizeof (int_least8_t), CFI_type_int_least8_t);
+ check (arg_least16, sizeof (int_least16_t), CFI_type_int_least16_t);
+ check (arg_least32, sizeof (int_least32_t), CFI_type_int_least32_t);
+ check (arg_least64, sizeof (int_least64_t), CFI_type_int_least64_t);
+}
+
+/* Check the int_fast*_t types. */
+void
+ctest_int4 (CFI_cdesc_t *arg_fast8,
+ CFI_cdesc_t *arg_fast16,
+ CFI_cdesc_t *arg_fast32,
+ CFI_cdesc_t *arg_fast64)
+{
+ check (arg_fast8, sizeof (int_fast8_t), CFI_type_int_fast8_t);
+ check (arg_fast16, sizeof (int_fast16_t), CFI_type_int_fast16_t);
+ check (arg_fast32, sizeof (int_fast32_t), CFI_type_int_fast32_t);
+ check (arg_fast64, sizeof (int_fast64_t), CFI_type_int_fast64_t);
+}
+
+/* Check the "purposeful" integer types. */
+void
+ctest_int5 (CFI_cdesc_t *arg_size,
+ CFI_cdesc_t *arg_intmax,
+ CFI_cdesc_t *arg_intptr,
+ CFI_cdesc_t *arg_ptrdiff)
+{
+ check (arg_size, sizeof (size_t), CFI_type_size_t);
+ check (arg_intmax, sizeof (intmax_t), CFI_type_intmax_t);
+ check (arg_intptr, sizeof (intptr_t), CFI_type_intptr_t);
+ check (arg_ptrdiff, sizeof (ptrdiff_t), CFI_type_ptrdiff_t);
+}
+
+/* Check the floating-point types. */
+void
+ctest_real (CFI_cdesc_t *arg_float,
+ CFI_cdesc_t *arg_double)
+{
+ check (arg_float, sizeof (float), CFI_type_float);
+ check (arg_double, sizeof (double), CFI_type_double);
+}
+
+/* Likewise for the complex types. */
+void
+ctest_complex (CFI_cdesc_t *arg_float_complex,
+ CFI_cdesc_t *arg_double_complex)
+{
+ check (arg_float_complex, sizeof (float _Complex),
+ CFI_type_float_Complex);
+ check (arg_double_complex, sizeof (double _Complex),
+ CFI_type_double_Complex);
+}
+
+/* Misc types. */
+void
+ctest_misc (CFI_cdesc_t *arg_bool,
+ CFI_cdesc_t *arg_cptr,
+ CFI_cdesc_t *arg_cfunptr,
+ CFI_cdesc_t *arg_struct)
+{
+ struct m
+ {
+ int i, j;
+ };
+
+ check (arg_bool, sizeof (_Bool), CFI_type_Bool);
+ check (arg_cptr, sizeof (void *), CFI_type_cptr);
+ check (arg_cfunptr, sizeof (void (*)(void)), CFI_type_cfunptr);
+ check (arg_struct, sizeof (struct m), CFI_type_struct);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-basic.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-basic.f90
new file mode 100644
index 00000000000..a91a6e85be9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-basic.f90
@@ -0,0 +1,151 @@
+! PR 101305
+! PR 100917
+! { dg-do run }
+! { dg-additional-sources "typecodes-array-basic-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests that kind constants in the ISO_C_BINDING
+! module result in the right type field in arguments passed by descriptor,
+! also matching the size of the corresponding C type. We use
+! assumed-rank arrays to force the use of a descriptor.
+!
+! Some types are tested in their own testcases to allow conditionalization
+! for target-specific support or xfailing to track bugs.
+
+module mm
+ use iso_c_binding
+
+ type, bind (c) :: s
+ integer(C_INT) :: i, j
+ end type
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+
+ subroutine ctest_int1 (arg_int, arg_short, arg_long, arg_long_long, &
+ arg_signed_char) bind (c)
+ use iso_c_binding
+ integer(C_INT) :: arg_int(:)
+ integer(C_SHORT) :: arg_short(:)
+ integer(C_LONG) :: arg_long(:)
+ integer(C_LONG_LONG) :: arg_long_long(:)
+ integer(C_SIGNED_CHAR) :: arg_signed_char(:)
+ end subroutine
+
+ subroutine ctest_int2 (arg_int8, arg_int16, arg_int32, arg_int64) bind (c)
+ use iso_c_binding
+ integer(C_INT8_T) :: arg_int8(:)
+ integer(C_INT16_T) :: arg_int16(:)
+ integer(C_INT32_T) :: arg_int32(:)
+ integer(C_INT64_T) :: arg_int64(:)
+ end subroutine
+
+ subroutine ctest_int3 (arg_least8, arg_least16, arg_least32, &
+ arg_least64) bind (c)
+ use iso_c_binding
+ integer(C_INT_LEAST8_T) :: arg_least8(:)
+ integer(C_INT_LEAST16_T) :: arg_least16(:)
+ integer(C_INT_LEAST32_T) :: arg_least32(:)
+ integer(C_INT_LEAST64_T) :: arg_least64(:)
+ end subroutine
+
+ subroutine ctest_int4 (arg_fast8, arg_fast16, arg_fast32, &
+ arg_fast64) bind (c)
+ use iso_c_binding
+ integer(C_INT_FAST8_T) :: arg_fast8(:)
+ integer(C_INT_FAST16_T) :: arg_fast16(:)
+ integer(C_INT_FAST32_T) :: arg_fast32(:)
+ integer(C_INT_FAST64_T) :: arg_fast64(:)
+ end subroutine
+
+ subroutine ctest_int5 (arg_size, arg_intmax, arg_intptr, &
+ arg_ptrdiff) bind (c)
+ use iso_c_binding
+ integer(C_SIZE_T) :: arg_size(:)
+ integer(C_INTMAX_T) :: arg_intmax(:)
+ integer(C_INTPTR_T) :: arg_intptr(:)
+ integer(C_PTRDIFF_T) :: arg_ptrdiff(:)
+ end subroutine
+
+ subroutine ctest_real (arg_float, arg_double) bind (c)
+ use iso_c_binding
+ real(C_FLOAT) :: arg_float(:)
+ real(C_DOUBLE) :: arg_double(:)
+ end subroutine
+
+ subroutine ctest_complex (arg_float_complex, arg_double_complex) &
+ bind (c)
+ use iso_c_binding
+ complex(C_FLOAT_COMPLEX) :: arg_float_complex(:)
+ complex(C_DOUBLE_COMPLEX) :: arg_double_complex(:)
+ end subroutine
+
+ subroutine ctest_misc (arg_bool, arg_cptr, arg_cfunptr, &
+ arg_struct) bind (c)
+ use iso_c_binding
+ use mm
+ logical(C_BOOL) :: arg_bool(:)
+ type(C_PTR) :: arg_cptr(:)
+ type(C_FUNPTR) :: arg_cfunptr(:)
+ type(s) :: arg_struct(:)
+ end subroutine
+
+ end interface
+
+ integer(C_INT) :: var_int(4)
+ integer(C_SHORT) :: var_short(4)
+ integer(C_LONG) :: var_long(4)
+ integer(C_LONG_LONG) :: var_long_long(4)
+ integer(C_SIGNED_CHAR) :: var_signed_char(4)
+ integer(C_INT8_T) :: var_int8(4)
+ integer(C_INT16_T) :: var_int16(4)
+ integer(C_INT32_T) :: var_int32(4)
+ integer(C_INT64_T) :: var_int64(4)
+ integer(C_INT_LEAST8_T) :: var_least8(4)
+ integer(C_INT_LEAST16_T) :: var_least16(4)
+ integer(C_INT_LEAST32_T) :: var_least32(4)
+ integer(C_INT_LEAST64_T) :: var_least64(4)
+ integer(C_INT_FAST8_T) :: var_fast8(4)
+ integer(C_INT_FAST16_T) :: var_fast16(4)
+ integer(C_INT_FAST32_T) :: var_fast32(4)
+ integer(C_INT_FAST64_T) :: var_fast64(4)
+ integer(C_SIZE_T) :: var_size(4)
+ integer(C_INTMAX_T) :: var_intmax(4)
+ integer(C_INTPTR_T) :: var_intptr(4)
+ integer(C_PTRDIFF_T) :: var_ptrdiff(4)
+ real(C_FLOAT) :: var_float(4)
+ real(C_DOUBLE) :: var_double(4)
+ complex(C_FLOAT_COMPLEX) :: var_float_complex(4)
+ complex(C_DOUBLE_COMPLEX) :: var_double_complex(4)
+ logical(C_BOOL) :: var_bool(4)
+ type(C_PTR) :: var_cptr(4)
+ type(C_FUNPTR) :: var_cfunptr(4)
+ type(s) :: var_struct(4)
+
+ call ctest_int1 (var_int, var_short, var_long, var_long_long, &
+ var_signed_char)
+
+ call ctest_int2 (var_int8, var_int16, var_int32, var_int64)
+
+ call ctest_int3 (var_least8, var_least16, var_least32, var_least64)
+
+ call ctest_int4 (var_fast8, var_fast16, var_fast32, var_fast64)
+
+ call ctest_int5 (var_size, var_intmax, var_intptr, var_ptrdiff)
+
+ call ctest_real (var_float, var_double)
+
+ call ctest_complex (var_float_complex, var_double_complex)
+
+ call ctest_misc (var_bool, var_cptr, var_cfunptr, var_struct)
+
+ ! FIXME: how do you pass something that corresponds to CFI_type_other?
+ ! The Fortran front end complains if you try to pass something that
+ ! isn't interoperable, such as a derived type object without bind(c).
+
+end program
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
new file mode 100644
index 00000000000..c69d2242865
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char-c.c
@@ -0,0 +1,35 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest_1 (CFI_cdesc_t *arg_char, CFI_cdesc_t *arg_ucs4);
+
+/* Sanity check the type info in the descriptor a. */
+
+static void
+check (CFI_cdesc_t *a, size_t size, int typecode)
+{
+ dump_CFI_cdesc_t (a);
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->base_addr == NULL)
+ abort ();
+ if (a->rank != 1)
+ abort ();
+ if (size && a->elem_len != size)
+ abort ();
+ if (a->type != typecode)
+ abort ();
+}
+
+void
+ctest_1 (CFI_cdesc_t *arg_char, CFI_cdesc_t *arg_ucs4)
+{
+ check (arg_char, 1, CFI_type_char);
+ check (arg_ucs4, 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
new file mode 100644
index 00000000000..ede9fb6039a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char.f90
@@ -0,0 +1,37 @@
+! PR 101305
+! PR 92482
+! { dg-do run }
+! { dg-additional-sources "typecodes-array-char-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests that the character kind constants provided by
+! gfortran's ISO_C_BINDING module result in the right type field in
+! arguments passed by descriptor, also matching the size of the corresponding
+! C type. We use assumed-shape arrays to force the use of a descriptor.
+!
+! FIXME: because of PR92482, we can only test len=1 characters. This
+! test should be extended once that bug is fixed.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ integer, parameter :: ucs4 = selected_char_kind ('ISO_10646')
+
+ interface
+
+ subroutine ctest_1 (arg_cchar, arg_ucs4) bind (c)
+ use iso_c_binding
+ integer, parameter :: ucs4 = selected_char_kind ('ISO_10646')
+ character(kind=C_CHAR) :: arg_cchar(:)
+ character(kind=ucs4) :: arg_ucs4(:)
+ end subroutine
+
+ end interface
+
+ character(kind=C_CHAR) :: var_cchar(4)
+ character(kind=ucs4) :: var_ucs4(4)
+
+ call ctest_1 (var_cchar, var_ucs4)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128-c.c b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128-c.c
new file mode 100644
index 00000000000..d081febaaf4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128-c.c
@@ -0,0 +1,38 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *arg_float128,
+ CFI_cdesc_t *arg_complex128);
+
+
+/* Sanity check the type info in the descriptor a. */
+
+static void
+check (CFI_cdesc_t *a, size_t size, int typecode)
+{
+ dump_CFI_cdesc_t (a);
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->base_addr == NULL)
+ abort ();
+ if (a->rank != 1)
+ abort ();
+ if (size && a->elem_len != size)
+ abort ();
+ if (a->type != typecode)
+ abort ();
+}
+
+void
+ctest (CFI_cdesc_t *arg_float128,
+ CFI_cdesc_t *arg_complex128)
+{
+ check (arg_float128, sizeof (__float128), CFI_type_float128);
+ check (arg_complex128, sizeof (__float128) * 2,
+ CFI_type_float128_Complex);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128.f90
new file mode 100644
index 00000000000..907877b923e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128.f90
@@ -0,0 +1,34 @@
+! PR 101305
+! PR 100914
+! PR 100917
+! Fails on x86 targets where sizeof(long double) == 16 (PR100917).
+! { dg-do run { xfail { { x86_64*-*-* i?86*-*-* } && longdouble128 } } }
+! { dg-require-effective-target fortran_real_c_float128 }
+! { dg-additional-sources "typecodes-array-float128-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests that the vendor extension kind constants provided by
+! gfortran's ISO_C_BINDING module result in the right type field in
+! arguments passed by descriptor, also matching the size of the corresponding
+! C type. We use assumed-shape arrays to force the use of a descriptor.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+
+ subroutine ctest (arg_float128, arg_complex128) bind (c)
+ use iso_c_binding
+ real(C_FLOAT128) :: arg_float128(:)
+ complex(C_FLOAT128_COMPLEX) :: arg_complex128(:)
+ end subroutine
+
+ end interface
+
+ real(C_FLOAT128) :: var_float128(4)
+ complex(C_FLOAT128_COMPLEX) :: var_complex128(4)
+
+ call ctest (var_float128, var_complex128)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-int128-c.c b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-int128-c.c
new file mode 100644
index 00000000000..f6f8c751c48
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-int128-c.c
@@ -0,0 +1,40 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *arg_int128,
+ CFI_cdesc_t *arg_least128,
+ CFI_cdesc_t *arg_fast128);
+
+/* Sanity check the type info in the descriptor a. */
+
+static void
+check (CFI_cdesc_t *a, size_t size, int typecode)
+{
+ dump_CFI_cdesc_t (a);
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->base_addr == NULL)
+ abort ();
+ if (a->rank != 1)
+ abort ();
+ if (size && a->elem_len != size)
+ abort ();
+ if (a->type != typecode)
+ abort ();
+}
+
+void
+ctest (CFI_cdesc_t *arg_int128,
+ CFI_cdesc_t *arg_least128,
+ CFI_cdesc_t *arg_fast128)
+{
+ check (arg_int128, sizeof (__int128), CFI_type_int128_t);
+ check (arg_least128, sizeof (__int128), CFI_type_int_least128_t);
+ check (arg_fast128, sizeof (__int128), CFI_type_int_fast128_t);
+}
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-int128.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-int128.f90
new file mode 100644
index 00000000000..671c544edfe
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-int128.f90
@@ -0,0 +1,33 @@
+! PR 101305
+! { dg-do run }
+! { dg-require-effective-target fortran_integer_16 }
+! { dg-additional-sources "typecodes-array-int128-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests that 128-bit integer kind constants provided by
+! gfortran's ISO_C_BINDING module result in the right type field in
+! arguments passed by descriptor, also matching the size of the corresponding
+! C type. We use assumed-shape arrays to force the use of a descriptor.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+
+ subroutine ctest (arg_int128, arg_least128, arg_fast128) bind (c)
+ use iso_c_binding
+ integer(C_INT128_T) :: arg_int128(:)
+ integer(C_INT_LEAST128_T) :: arg_least128(:)
+ integer(C_INT_FAST128_T) :: arg_fast128(:)
+ end subroutine
+
+ end interface
+
+ integer(C_INT128_T) :: var_int128(4)
+ integer(C_INT_LEAST128_T) :: var_least128(4)
+ integer(C_INT_FAST128_T) :: var_fast128(4)
+
+ call ctest (var_int128, var_least128, var_fast128)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-longdouble-c.c b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-longdouble-c.c
new file mode 100644
index 00000000000..e47e4e3cead
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-longdouble-c.c
@@ -0,0 +1,37 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *arg_long_double,
+ CFI_cdesc_t *arg_long_double_complex);
+
+/* Sanity check the type info in the descriptor a. */
+
+static void
+check (CFI_cdesc_t *a, size_t size, int typecode)
+{
+ dump_CFI_cdesc_t (a);
+ if (a->attribute != CFI_attribute_other)
+ abort ();
+ if (a->base_addr == NULL)
+ abort ();
+ if (a->rank != 1)
+ abort ();
+ if (size && a->elem_len != size)
+ abort ();
+ if (a->type != typecode)
+ abort ();
+}
+
+void
+ctest (CFI_cdesc_t *arg_long_double,
+ CFI_cdesc_t *arg_long_double_complex)
+{
+ check (arg_long_double, sizeof (long double), CFI_type_long_double);
+ check (arg_long_double_complex, sizeof (long double _Complex),
+ CFI_type_long_double_Complex);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-longdouble.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-longdouble.f90
new file mode 100644
index 00000000000..100071fd500
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-array-longdouble.f90
@@ -0,0 +1,32 @@
+! PR 101305
+! PR 100917
+! { dg-do run }
+! { dg-additional-sources "typecodes-array-longdouble-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests that long double kind constants in the ISO_C_BINDING
+! module result in the right type field in arguments passed by descriptor,
+! also matching the size of the corresponding C type. We use
+! assumed-rank arrays to force the use of a descriptor.
+
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+
+ subroutine ctest (arg_long_double, arg_long_double_complex) bind (c)
+ use iso_c_binding
+ real(C_LONG_DOUBLE) :: arg_long_double(:)
+ complex(C_LONG_DOUBLE_COMPLEX) :: arg_long_double_complex(:)
+ end subroutine
+
+ end interface
+
+ real(C_LONG_DOUBLE) :: var_long_double(4)
+ complex(C_LONG_DOUBLE_COMPLEX) :: var_long_double_complex(4)
+
+ call ctest (var_long_double, var_long_double_complex)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-sanity-c.c b/gcc/testsuite/gfortran.dg/c-interop/typecodes-sanity-c.c
new file mode 100644
index 00000000000..a1d044b8040
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-sanity-c.c
@@ -0,0 +1,179 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+
+extern void ctest_typecodes (void);
+
+/* Do sanity checking on the CFI_type_* macros. In particular, make sure
+ that if two type codes have the same value, they represent objects of the
+ same size. */
+
+struct tc_info
+{
+ CFI_type_t typecode;
+ char *name;
+ size_t size;
+ int extension;
+};
+
+static struct tc_info tc_table[] =
+{
+ /* Extension types.
+ Note there is no portable C equivalent type for CFI_type_ucs4_char type
+ (4-byte Unicode characters), and GCC rejects "__float128 _Complex",
+ so this is kind of hacky... */
+#if CFI_type_int128_t > 0
+ { CFI_type_int128_t, "CFI_type_int128_t",
+ sizeof (__int128), 1 },
+ { CFI_type_int_least128_t, "CFI_type_int_least128_t",
+ sizeof (__int128), 1 },
+ { CFI_type_int_fast128_t, "CFI_type_int_fast128_t",
+ sizeof (__int128), 1 },
+#endif
+#if CFI_type_ucs4_char > 0
+ { CFI_type_ucs4_char, "CFI_type_ucs4_char", 4, 1 },
+#endif
+#if CFI_type_float128 > 0
+ { CFI_type_float128, "CFI_type_float128",
+ sizeof (__float128), 1 },
+ { CFI_type_float128_Complex, "CFI_type_float128_Complex",
+ sizeof (__float128) * 2, 1 },
+#endif
+#if CFI_type_cfunptr > 0
+ { CFI_type_cfunptr, "CFI_type_cfunptr",
+ sizeof (void (*)(void)), 1 },
+#endif
+
+ /* Standard types. */
+ { CFI_type_signed_char, "CFI_type_signed_char",
+ sizeof (signed char), 0, },
+ { CFI_type_short, "CFI_type_short",
+ sizeof (short), 0 },
+ { CFI_type_int, "CFI_type_int",
+ sizeof (int), 0 },
+ { CFI_type_long, "CFI_type_long",
+ sizeof (long), 0 },
+ { CFI_type_long_long, "CFI_type_long_long",
+ sizeof (long long), 0 },
+ { CFI_type_size_t, "CFI_type_size_t",
+ sizeof (size_t), 0 },
+ { CFI_type_int8_t, "CFI_type_int8_t",
+ sizeof (int8_t), 0 },
+ { CFI_type_int16_t, "CFI_type_int16_t",
+ sizeof (int16_t), 0 },
+ { CFI_type_int32_t, "CFI_type_int32_t",
+ sizeof (int32_t), 0 },
+ { CFI_type_int64_t, "CFI_type_int64_t",
+ sizeof (int64_t), 0 },
+ { CFI_type_int_least8_t, "CFI_type_int_least8_t",
+ sizeof (int_least8_t), 0 },
+ { CFI_type_int_least16_t, "CFI_type_int_least16_t",
+ sizeof (int_least16_t), 0 },
+ { CFI_type_int_least32_t, "CFI_type_int_least32_t",
+ sizeof (int_least32_t), 0 },
+ { CFI_type_int_least64_t, "CFI_type_int_least64_t",
+ sizeof (int_least64_t), 0 },
+ { CFI_type_int_fast8_t, "CFI_type_int_fast8_t",
+ sizeof (int_fast8_t), 0 },
+ { CFI_type_int_fast16_t, "CFI_type_int_fast16_t",
+ sizeof (int_fast16_t), 0 },
+ { CFI_type_int_fast32_t, "CFI_type_int_fast32_t",
+ sizeof (int_fast32_t), 0 },
+ { CFI_type_int_fast64_t, "CFI_type_int_fast64_t",
+ sizeof (int_fast64_t), 0 },
+ { CFI_type_intmax_t, "CFI_type_intmax_t",
+ sizeof (intmax_t), 0 },
+ { CFI_type_intptr_t, "CFI_type_intptr_t",
+ sizeof (intptr_t), 0 },
+ { CFI_type_ptrdiff_t, "CFI_type_ptrdiff_t",
+ sizeof (ptrdiff_t), 0 },
+ { CFI_type_float, "CFI_type_float",
+ sizeof (float), 0 },
+ { CFI_type_double, "CFI_type_double",
+ sizeof (double), 0 },
+ { CFI_type_long_double, "CFI_type_long_double",
+ sizeof (long double), 0 },
+ { CFI_type_float_Complex, "CFI_type_float_Complex",
+ sizeof (float _Complex), 0 },
+ { CFI_type_double_Complex, "CFI_type_double_Complex",
+ sizeof (double _Complex), 0 },
+ { CFI_type_long_double_Complex, "CFI_type_long_double_Complex",
+ sizeof (long double _Complex), 0 },
+ { CFI_type_Bool, "CFI_type_Bool",
+ sizeof (_Bool), 0 },
+ { CFI_type_char, "CFI_type_char",
+ sizeof (char), 0 },
+ { CFI_type_cptr, "CFI_type_cptr",
+ sizeof (void *), 0 },
+ { CFI_type_struct, "CFI_type_struct", 0, 0 },
+ { CFI_type_other, "CFI_type_other", -1, 0, }
+};
+
+void
+ctest_typecodes (void)
+{
+ int ncodes = sizeof (tc_table) / sizeof (struct tc_info);
+ int i, j;
+ int bad = 0;
+
+ for (i = 0; i < ncodes; i++)
+ for (j = i + 1; j < ncodes; j++)
+ if (tc_table[i].typecode == tc_table[j].typecode
+ && tc_table[i].typecode > 0
+ && (tc_table[i].size != tc_table[j].size))
+ {
+ fprintf (stderr,
+ "type codes have the same value %d but different sizes\n",
+ (int) tc_table[i].typecode);
+ fprintf (stderr, " %s size %d\n",
+ tc_table[i].name, (int) tc_table[i].size);
+ fprintf (stderr, " %s size %d\n",
+ tc_table[j].name, (int) tc_table[j].size);
+ bad = 1;
+ }
+
+ /* TS29113 Section 8.3.4: The value for CFI_type_other shall be negative
+ and distinct from all other type specifiers. If a C type is not
+ interoperable with a Fortran type and kind supported by the
+ Fortran processor, its macro shall evaluate to a negative value.
+ Otherwise, the value for an intrinsic type shall be positive.
+
+ In the case of GCC, we expect that all the standard intrinsic
+ types are supported by both Fortran and C, so they should all be
+ positive except for CFI_type_other. Non-standard ones may have a
+ value -2. */
+
+ for (i = 0; i < ncodes; i++)
+ {
+ if (tc_table[i].typecode == CFI_type_other)
+ {
+ if (tc_table[i].typecode >= 0)
+ {
+ fprintf (stderr, "%s value %d is not negative\n",
+ tc_table[i].name, (int)tc_table[i].typecode);
+ bad = 1;
+ }
+ if (strcmp (tc_table[i].name, "CFI_type_other"))
+ {
+ fprintf (stderr, "%s has the same value %d as CFI_type_other\n",
+ tc_table[i].name, (int)CFI_type_other);
+ bad = 1;
+ }
+ }
+ else if (tc_table[i].typecode == -2 && tc_table[i].extension)
+ /* Unsupported extension type on this target; this is OK */
+ ;
+ else if (tc_table[i].typecode <= 0)
+ {
+ fprintf (stderr, "%s value %d is not positive\n",
+ tc_table[i].name, (int)tc_table[i].typecode);
+ bad = 1;
+ }
+ }
+
+ if (bad)
+ abort ();
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-sanity.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-sanity.f90
new file mode 100644
index 00000000000..7dcc62d916c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-sanity.f90
@@ -0,0 +1,24 @@
+! PR 101305
+! { dg-do run }
+! { dg-additional-sources "typecodes-sanity-c.c" }
+! { dg-additional-options "-g" }
+!
+! This program does sanity checking on the CFI_type_* macros. All
+! of the interesting things happen on the C side.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ integer, parameter :: ucs4 = selected_char_kind ('ISO_10646')
+
+ interface
+
+ subroutine ctest_typecodes () bind (c)
+ end subroutine
+
+ end interface
+
+ call ctest_typecodes ()
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic-c.c b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic-c.c
new file mode 100644
index 00000000000..fe1a10a1aac
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic-c.c
@@ -0,0 +1,168 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest_int1 (CFI_cdesc_t *arg_int,
+ CFI_cdesc_t *arg_short,
+ CFI_cdesc_t *arg_long,
+ CFI_cdesc_t *arg_long_long,
+ CFI_cdesc_t *arg_signed_char);
+
+extern void ctest_int2 (CFI_cdesc_t *arg_int8,
+ CFI_cdesc_t *arg_int16,
+ CFI_cdesc_t *arg_int32,
+ CFI_cdesc_t *arg_int64);
+
+extern void ctest_int3 (CFI_cdesc_t *arg_least8,
+ CFI_cdesc_t *arg_least16,
+ CFI_cdesc_t *arg_least32,
+ CFI_cdesc_t *arg_least64);
+
+extern void ctest_int4 (CFI_cdesc_t *arg_fast8,
+ CFI_cdesc_t *arg_fast16,
+ CFI_cdesc_t *arg_fast32,
+ CFI_cdesc_t *arg_fast64);
+
+extern void ctest_int5 (CFI_cdesc_t *arg_size,
+ CFI_cdesc_t *arg_intmax,
+ CFI_cdesc_t *arg_intptr,
+ CFI_cdesc_t *arg_ptrdiff);
+
+extern void ctest_real (CFI_cdesc_t *arg_float,
+ CFI_cdesc_t *arg_double);
+
+extern void ctest_complex (CFI_cdesc_t *arg_float_complex,
+ CFI_cdesc_t *arg_double_complex);
+
+extern void ctest_misc (CFI_cdesc_t *arg_bool,
+ CFI_cdesc_t *arg_cptr,
+ CFI_cdesc_t *arg_cfunptr,
+ CFI_cdesc_t *arg_struct);
+
+/* Sanity check the type info in the descriptor a. */
+
+static void
+check (CFI_cdesc_t *a, size_t size, int typecode)
+{
+ dump_CFI_cdesc_t (a);
+ if (a->attribute != CFI_attribute_pointer)
+ abort ();
+ if (a->base_addr != NULL)
+ abort ();
+ if (a->rank != 0)
+ abort ();
+ if (size && a->elem_len != size)
+ abort ();
+ if (a->type != typecode)
+ abort ();
+}
+
+
+/* Test that the basic integer types correspond correctly. */
+void
+ctest_int1 (CFI_cdesc_t *arg_int,
+ CFI_cdesc_t *arg_short,
+ CFI_cdesc_t *arg_long,
+ CFI_cdesc_t *arg_long_long,
+ CFI_cdesc_t *arg_signed_char)
+{
+ check (arg_int, sizeof (int), CFI_type_int);
+ check (arg_short, sizeof (short), CFI_type_short);
+ check (arg_long, sizeof (long), CFI_type_long);
+ check (arg_long_long, sizeof (long long int), CFI_type_long_long);
+ check (arg_signed_char, sizeof (signed char), CFI_type_signed_char);
+}
+
+/* Test the integer types of explicit sizes. */
+void
+ctest_int2 (CFI_cdesc_t *arg_int8,
+ CFI_cdesc_t *arg_int16,
+ CFI_cdesc_t *arg_int32,
+ CFI_cdesc_t *arg_int64)
+{
+ check (arg_int8, sizeof (int8_t), CFI_type_int8_t);
+ check (arg_int16, sizeof (int16_t), CFI_type_int16_t);
+ check (arg_int32, sizeof (int32_t), CFI_type_int32_t);
+ check (arg_int64, sizeof (int64_t), CFI_type_int64_t);
+}
+
+/* Check the int_least*_t types. */
+
+void
+ctest_int3 (CFI_cdesc_t *arg_least8,
+ CFI_cdesc_t *arg_least16,
+ CFI_cdesc_t *arg_least32,
+ CFI_cdesc_t *arg_least64)
+{
+ check (arg_least8, sizeof (int_least8_t), CFI_type_int_least8_t);
+ check (arg_least16, sizeof (int_least16_t), CFI_type_int_least16_t);
+ check (arg_least32, sizeof (int_least32_t), CFI_type_int_least32_t);
+ check (arg_least64, sizeof (int_least64_t), CFI_type_int_least64_t);
+}
+
+/* Check the int_fast*_t types. */
+void
+ctest_int4 (CFI_cdesc_t *arg_fast8,
+ CFI_cdesc_t *arg_fast16,
+ CFI_cdesc_t *arg_fast32,
+ CFI_cdesc_t *arg_fast64)
+{
+ check (arg_fast8, sizeof (int_fast8_t), CFI_type_int_fast8_t);
+ check (arg_fast16, sizeof (int_fast16_t), CFI_type_int_fast16_t);
+ check (arg_fast32, sizeof (int_fast32_t), CFI_type_int_fast32_t);
+ check (arg_fast64, sizeof (int_fast64_t), CFI_type_int_fast64_t);
+}
+
+/* Check the "purposeful" integer types. */
+void
+ctest_int5 (CFI_cdesc_t *arg_size,
+ CFI_cdesc_t *arg_intmax,
+ CFI_cdesc_t *arg_intptr,
+ CFI_cdesc_t *arg_ptrdiff)
+{
+ check (arg_size, sizeof (size_t), CFI_type_size_t);
+ check (arg_intmax, sizeof (intmax_t), CFI_type_intmax_t);
+ check (arg_intptr, sizeof (intptr_t), CFI_type_intptr_t);
+ check (arg_ptrdiff, sizeof (ptrdiff_t), CFI_type_ptrdiff_t);
+}
+
+/* Check the floating-point types. */
+void
+ctest_real (CFI_cdesc_t *arg_float,
+ CFI_cdesc_t *arg_double)
+{
+ check (arg_float, sizeof (float), CFI_type_float);
+ check (arg_double, sizeof (double), CFI_type_double);
+}
+
+/* Likewise for the complex types. */
+void
+ctest_complex (CFI_cdesc_t *arg_float_complex,
+ CFI_cdesc_t *arg_double_complex)
+{
+ check (arg_float_complex, sizeof (float _Complex),
+ CFI_type_float_Complex);
+ check (arg_double_complex, sizeof (double _Complex),
+ CFI_type_double_Complex);
+}
+
+/* Misc types. */
+void
+ctest_misc (CFI_cdesc_t *arg_bool,
+ CFI_cdesc_t *arg_cptr,
+ CFI_cdesc_t *arg_cfunptr,
+ CFI_cdesc_t *arg_struct)
+{
+ struct m
+ {
+ int i, j;
+ };
+
+ check (arg_bool, sizeof (_Bool), CFI_type_Bool);
+ check (arg_cptr, sizeof (void *), CFI_type_cptr);
+ check (arg_struct, sizeof (struct m), CFI_type_struct);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic.f90
new file mode 100644
index 00000000000..5f7446826a8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic.f90
@@ -0,0 +1,160 @@
+! PR 101305
+! PR 100917
+! xfailed due to PR 101308
+! { dg-do run { xfail *-*-* } }
+! { dg-additional-sources "typecodes-scalar-basic-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests that kind constants in the ISO_C_BINDING
+! module result in the right type field in arguments passed by descriptor,
+! also matching the size of the corresponding C type. We use pointers
+! to force the use of a descriptor.
+!
+! Some types are tested in their own testcases to allow conditionalization
+! for target-specific support or xfailing to track bugs.
+
+module mm
+ use iso_c_binding
+
+ type, bind (c) :: s
+ integer(C_INT) :: i, j
+ end type
+end module
+
+program testit
+ use iso_c_binding
+ use mm
+ implicit none
+
+ interface
+
+ subroutine ctest_int1 (arg_int, arg_short, arg_long, arg_long_long, &
+ arg_signed_char) bind (c)
+ use iso_c_binding
+ integer(C_INT), pointer :: arg_int
+ integer(C_SHORT), pointer :: arg_short
+ integer(C_LONG), pointer :: arg_long
+ integer(C_LONG_LONG), pointer :: arg_long_long
+ integer(C_SIGNED_CHAR), pointer :: arg_signed_char
+ end subroutine
+
+ subroutine ctest_int2 (arg_int8, arg_int16, arg_int32, arg_int64) bind (c)
+ use iso_c_binding
+ integer(C_INT8_T), pointer :: arg_int8
+ integer(C_INT16_T), pointer :: arg_int16
+ integer(C_INT32_T), pointer :: arg_int32
+ integer(C_INT64_T), pointer :: arg_int64
+ end subroutine
+
+ subroutine ctest_int3 (arg_least8, arg_least16, arg_least32, &
+ arg_least64) bind (c)
+ use iso_c_binding
+ integer(C_INT_LEAST8_T), pointer :: arg_least8
+ integer(C_INT_LEAST16_T), pointer :: arg_least16
+ integer(C_INT_LEAST32_T), pointer :: arg_least32
+ integer(C_INT_LEAST64_T), pointer :: arg_least64
+ end subroutine
+
+ subroutine ctest_int4 (arg_fast8, arg_fast16, arg_fast32, &
+ arg_fast64) bind (c)
+ use iso_c_binding
+ integer(C_INT_FAST8_T), pointer :: arg_fast8
+ integer(C_INT_FAST16_T), pointer :: arg_fast16
+ integer(C_INT_FAST32_T), pointer :: arg_fast32
+ integer(C_INT_FAST64_T), pointer :: arg_fast64
+ end subroutine
+
+ subroutine ctest_int5 (arg_size, arg_intmax, arg_intptr, &
+ arg_ptrdiff) bind (c)
+ use iso_c_binding
+ integer(C_SIZE_T), pointer :: arg_size
+ integer(C_INTMAX_T), pointer :: arg_intmax
+ integer(C_INTPTR_T), pointer :: arg_intptr
+ integer(C_PTRDIFF_T), pointer :: arg_ptrdiff
+ end subroutine
+
+ subroutine ctest_real (arg_float, arg_double) bind (c)
+ use iso_c_binding
+ real(C_FLOAT), pointer :: arg_float
+ real(C_DOUBLE), pointer :: arg_double
+ end subroutine
+
+ subroutine ctest_complex (arg_float_complex, arg_double_complex) &
+ bind (c)
+ use iso_c_binding
+ complex(C_FLOAT_COMPLEX), pointer :: arg_float_complex
+ complex(C_DOUBLE_COMPLEX), pointer :: arg_double_complex
+ end subroutine
+
+ subroutine ctest_misc (arg_bool, arg_cptr, arg_cfunptr, arg_struct) &
+ bind (c)
+ use iso_c_binding
+ use mm
+ logical(C_BOOL), pointer :: arg_bool
+ type(C_PTR), pointer :: arg_cptr
+ type(C_FUNPTR), pointer :: arg_cfunptr
+ type(s), pointer :: arg_struct
+ end subroutine
+
+ end interface
+
+ integer(C_INT), pointer :: var_int
+ integer(C_SHORT), pointer :: var_short
+ integer(C_LONG), pointer :: var_long
+ integer(C_LONG_LONG), pointer :: var_long_long
+ integer(C_SIGNED_CHAR), pointer :: var_signed_char
+ integer(C_INT8_T), pointer :: var_int8
+ integer(C_INT16_T), pointer :: var_int16
+ integer(C_INT32_T), pointer :: var_int32
+ integer(C_INT64_T), pointer :: var_int64
+ integer(C_INT_LEAST8_T), pointer :: var_least8
+ integer(C_INT_LEAST16_T), pointer :: var_least16
+ integer(C_INT_LEAST32_T), pointer :: var_least32
+ integer(C_INT_LEAST64_T), pointer :: var_least64
+ integer(C_INT_FAST8_T), pointer :: var_fast8
+ integer(C_INT_FAST16_T), pointer :: var_fast16
+ integer(C_INT_FAST32_T), pointer :: var_fast32
+ integer(C_INT_FAST64_T), pointer :: var_fast64
+ integer(C_SIZE_T), pointer :: var_size
+ integer(C_INTMAX_T), pointer :: var_intmax
+ integer(C_INTPTR_T), pointer :: var_intptr
+ integer(C_PTRDIFF_T), pointer :: var_ptrdiff
+ real(C_FLOAT), pointer :: var_float
+ real(C_DOUBLE), pointer :: var_double
+ complex(C_FLOAT_COMPLEX), pointer :: var_float_complex
+ complex(C_DOUBLE_COMPLEX), pointer :: var_double_complex
+ logical(C_BOOL), pointer :: var_bool
+ type(C_PTR), pointer :: var_cptr
+ type(C_FUNPTR), pointer :: var_cfunptr
+ type(s), pointer :: var_struct
+
+ nullify (var_int, var_short, var_long, var_long_long, var_signed_char)
+ call ctest_int1 (var_int, var_short, var_long, var_long_long, &
+ var_signed_char)
+
+ nullify (var_int8, var_int16, var_int32, var_int64)
+ call ctest_int2 (var_int8, var_int16, var_int32, var_int64)
+
+ nullify (var_least8, var_least16, var_least32, var_least64)
+ call ctest_int3 (var_least8, var_least16, var_least32, var_least64)
+
+ nullify (var_fast8, var_fast16, var_fast32, var_fast64)
+ call ctest_int4 (var_fast8, var_fast16, var_fast32, var_fast64)
+
+ nullify (var_size, var_intmax, var_intptr, var_ptrdiff)
+ call ctest_int5 (var_size, var_intmax, var_intptr, var_ptrdiff)
+
+ nullify (var_float, var_double)
+ call ctest_real (var_float, var_double)
+
+ nullify (var_float_complex, var_double_complex)
+ call ctest_complex (var_float_complex, var_double_complex)
+
+ nullify (var_bool, var_cptr, var_cfunptr, var_struct)
+ call ctest_misc (var_bool, var_cptr, var_cfunptr, var_struct)
+
+ ! FIXME: how do you pass something that corresponds to CFI_type_other?
+ ! The Fortran front end complains if you try to pass something that
+ ! isn't interoperable, such as a derived type object without bind(c).
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128-c.c b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128-c.c
new file mode 100644
index 00000000000..f1833aab9fb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128-c.c
@@ -0,0 +1,38 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *arg_float128,
+ CFI_cdesc_t *arg_complex128);
+
+/* Sanity check the type info in the descriptor a. */
+
+static void
+check (CFI_cdesc_t *a, size_t size, int typecode)
+{
+ dump_CFI_cdesc_t (a);
+ if (a->attribute != CFI_attribute_pointer)
+ abort ();
+ if (a->base_addr != NULL)
+ abort ();
+ if (a->rank != 0)
+ abort ();
+ if (size && a->elem_len != size)
+ abort ();
+ if (a->type != typecode)
+ abort ();
+}
+
+void
+ctest (CFI_cdesc_t *arg_float128,
+ CFI_cdesc_t *arg_complex128)
+{
+ check (arg_float128, sizeof (__float128), CFI_type_float128);
+ check (arg_complex128, sizeof (__float128) * 2,
+ CFI_type_float128_Complex);
+}
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128.f90
new file mode 100644
index 00000000000..edf91450ff8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128.f90
@@ -0,0 +1,34 @@
+! xfailed due to PR 101308
+! PR 101305
+! PR 100914
+! { dg-do run { xfail *-*-* } }
+! { dg-require-effective-target fortran_real_c_float128 }
+! { dg-additional-sources "typecodes-scalar-float128-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests that the vendor extension kind constants provided by
+! gfortran's ISO_C_BINDING module result in the right type field in
+! arguments passed by descriptor,also matching the size of the corresponding
+! C type. We use pointers to force the use of a descriptor.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+
+ subroutine ctest (arg_float128, arg_complex128) bind (c)
+ use iso_c_binding
+ real(C_FLOAT128), pointer :: arg_float128
+ complex(C_FLOAT128_COMPLEX), pointer :: arg_complex128
+ end subroutine
+
+ end interface
+
+ real(C_FLOAT128), pointer :: var_float128
+ complex(C_FLOAT128_COMPLEX), pointer :: var_complex128
+
+ nullify (var_float128, var_complex128)
+ call ctest (var_float128, var_complex128)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128-c.c b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128-c.c
new file mode 100644
index 00000000000..db071080eb2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128-c.c
@@ -0,0 +1,41 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *arg_int128,
+ CFI_cdesc_t *arg_least128,
+ CFI_cdesc_t *arg_fast128);
+
+/* Sanity check the type info in the descriptor a. */
+
+static void
+check (CFI_cdesc_t *a, size_t size, int typecode)
+{
+ dump_CFI_cdesc_t (a);
+ if (a->attribute != CFI_attribute_pointer)
+ abort ();
+ if (a->base_addr != NULL)
+ abort ();
+ if (a->rank != 0)
+ abort ();
+ if (size && a->elem_len != size)
+ abort ();
+ if (a->type != typecode)
+ abort ();
+}
+
+void
+ctest (CFI_cdesc_t *arg_int128,
+ CFI_cdesc_t *arg_least128,
+ CFI_cdesc_t *arg_fast128)
+{
+ check (arg_int128, sizeof (__int128), CFI_type_int128_t);
+ check (arg_least128, sizeof (__int128), CFI_type_int_least128_t);
+ check (arg_fast128, sizeof (__int128), CFI_type_int_fast128_t);
+}
+
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128.f90
new file mode 100644
index 00000000000..5f3c7e1ccf7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128.f90
@@ -0,0 +1,35 @@
+! PR 101305
+! xfailed due to PR 101308
+! { dg-do run { xfail *-*-* } }
+! { dg-require-effective-target fortran_integer_16 }
+! { dg-additional-sources "typecodes-scalar-int128-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests that 128-bit integer kind constants provided by
+! gfortran's ISO_C_BINDING module result in the right type field in
+! arguments passed by descriptor, also matching the size of the corresponding
+! C type. We use pointers to force the use of a descriptor.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+
+ subroutine ctest (arg_int128, arg_least128, arg_fast128) bind (c)
+ use iso_c_binding
+ integer(C_INT128_T), pointer :: arg_int128
+ integer(C_INT_LEAST128_T), pointer :: arg_least128
+ integer(C_INT_FAST128_T), pointer :: arg_fast128
+ end subroutine
+
+ end interface
+
+ integer(C_INT128_T), pointer :: var_int128
+ integer(C_INT_LEAST128_T), pointer :: var_least128
+ integer(C_INT_FAST128_T), pointer :: var_fast128
+
+ nullify (var_int128, var_least128, var_fast128)
+ call ctest (var_int128, var_least128, var_fast128)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble-c.c b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble-c.c
new file mode 100644
index 00000000000..a52122f930f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble-c.c
@@ -0,0 +1,37 @@
+#include <stdlib.h>
+#include <stdint.h>
+#include <stdio.h>
+#include <string.h>
+
+#include <ISO_Fortran_binding.h>
+#include "dump-descriptors.h"
+
+extern void ctest (CFI_cdesc_t *arg_long_double,
+ CFI_cdesc_t *arg_long_double_complex);
+
+/* Sanity check the type info in the descriptor a. */
+
+static void
+check (CFI_cdesc_t *a, size_t size, int typecode)
+{
+ dump_CFI_cdesc_t (a);
+ if (a->attribute != CFI_attribute_pointer)
+ abort ();
+ if (a->base_addr != NULL)
+ abort ();
+ if (a->rank != 0)
+ abort ();
+ if (size && a->elem_len != size)
+ abort ();
+ if (a->type != typecode)
+ abort ();
+}
+
+void
+ctest (CFI_cdesc_t *arg_long_double,
+ CFI_cdesc_t *arg_long_double_complex)
+{
+ check (arg_long_double, sizeof (long double), CFI_type_long_double);
+ check (arg_long_double_complex, sizeof (long double _Complex),
+ CFI_type_long_double_Complex);
+}
diff --git a/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble.f90 b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble.f90
new file mode 100644
index 00000000000..c32e01218b6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble.f90
@@ -0,0 +1,33 @@
+! xfailed due to PR 101308
+! PR 101305
+! PR 100917
+! { dg-do run { xfail *-*-* } }
+! { dg-additional-sources "typecodes-scalar-longdouble-c.c dump-descriptors.c" }
+! { dg-additional-options "-g" }
+!
+! This program tests that long double kind constants in the ISO_C_BINDING
+! module result in the right type field in arguments passed by descriptor,
+! also matching the size of the corresponding C type. We use pointers
+! to force the use of a descriptor.
+
+program testit
+ use iso_c_binding
+ implicit none
+
+ interface
+
+ subroutine ctest (arg_long_double, arg_long_double_complex) bind (c)
+ use iso_c_binding
+ real(C_LONG_DOUBLE), pointer :: arg_long_double
+ complex(C_LONG_DOUBLE_COMPLEX), pointer :: arg_long_double_complex
+ end subroutine
+
+ end interface
+
+ real(C_LONG_DOUBLE), pointer :: var_long_double
+ complex(C_LONG_DOUBLE_COMPLEX), pointer :: var_long_double_complex
+
+ nullify (var_long_double, var_long_double_complex)
+ call ctest (var_long_double, var_long_double_complex)
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/c-interop/ubound.f90 b/gcc/testsuite/gfortran.dg/c-interop/ubound.f90
new file mode 100644
index 00000000000..37e073f692c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/ubound.f90
@@ -0,0 +1,129 @@
+! { dg-do run }
+!
+! TS 29113
+! 6.4.3 UBOUND
+!
+! The description of the intrinsic function UBOUND in ISO/IEC
+! 1539-1:2010 is changed for an assumed-rank object that is associated
+! with an assumed-size array; the result of UBOUND (ARRAY, RANK(ARRAY),
+! KIND) has a value equal to LBOUND (ARRAY, RANK (ARRAY), KIND) −2 with
+! KIND omitted from LBOUND if it was omitted from UBOUND.
+!
+! NOTE 6.2
+! If LBOUND or UBOUND is invoked for an assumed-rank object that is
+! associated with a scalar and DIM is absent, the result is a zero-sized
+! array. LBOUND or UBOUND cannot be invoked for an assumed-rank object
+! that is associated with a scalar if DIM is present because the rank of
+! a scalar is zero and DIM must be ≥ 1.
+!
+! The idea here is that the main program passes some arrays to a test
+! subroutine with an assumed-size dummy, which in turn passes that to a
+! subroutine with an assumed-rank dummy.
+
+program test
+
+ ! Define some arrays for testing.
+ integer, target :: x1(5)
+ integer :: y1(0:9)
+ integer, pointer :: p1(:)
+ integer, allocatable :: a1(:)
+ integer, target :: x3(2,3,4)
+ integer :: y3(0:1,-3:-1,4)
+ integer, pointer :: p3(:,:,:)
+ integer, allocatable :: a3(:,:,:)
+ integer :: x
+
+ ! Test the 1-dimensional arrays.
+ call test1 (x1)
+ call testit2(x1, shape(x1))
+ call test1 (y1)
+ call testit2(y1, shape(y1))
+ p1 => x1
+ call testit2(p1, shape(p1))
+ call testit2p(p1, lbound(p1), shape(p1))
+ call test1 (p1)
+ p1(77:) => x1
+ call testit2p(p1, [77], shape(p1))
+ allocate (a1(5))
+ call testit2(a1, shape(a1))
+ call testit2a(a1, lbound(a1), shape(a1))
+ call test1 (a1)
+ deallocate(a1)
+ allocate (a1(-38:5))
+ call test1 (a1)
+ call testit2(a1, shape(a1))
+ call testit2a(a1, [-38], shape(a1))
+
+ ! Test the multi-dimensional arrays.
+ call test3 (x3, 1, 2, 1, 3)
+ call test3 (y3, 0, 1, -3, -1)
+ p3 => x3
+ call test3 (p3, 1, 2, 1, 3)
+ allocate (a3(2,3,4))
+ call test3 (a3, 1, 2, 1, 3)
+
+ ! Test some scalars.
+ call test0 (x)
+ call test0 (-1)
+ call test0 (x1(1))
+
+contains
+
+ subroutine testit (a)
+ integer :: a(..)
+ integer :: r
+ r = rank(a)
+ if (any (lbound (a) .ne. 1)) stop 101
+ if (ubound (a, r) .ne. -1) stop 102
+ end subroutine
+
+ subroutine testit2(a, shape)
+ integer :: a(..)
+ integer :: shape(:)
+ if (rank(a) /= size(shape)) stop 111
+ if (any (lbound(a) /= 1)) stop 112
+ if (any (ubound(a) /= shape)) stop 113
+ end subroutine
+
+ subroutine testit2a(a,lbound2, shape2)
+ integer, allocatable :: a(..)
+ integer :: lbound2(:), shape2(:)
+ if (rank(a) /= size(shape2)) stop 121
+ if (any (lbound(a) /= lbound2)) stop 122
+ if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 123
+ if (any (shape(a) /= shape2)) stop 124
+ if (sum (shape(a)) /= size(a)) stop 125
+ end subroutine
+
+ subroutine testit2p(a, lbound2, shape2)
+ integer, pointer :: a(..)
+ integer :: lbound2(:), shape2(:)
+ if (rank(a) /= size(shape2)) stop 131
+ if (any (lbound(a) /= lbound2)) stop 132
+ if (any (ubound(a) /= lbound2 + shape2 - 1)) stop 133
+ if (any (shape(a) /= shape2)) stop 134
+ if (sum (shape(a)) /= size(a)) stop 135
+ end subroutine
+
+ subroutine test0 (a)
+ integer :: a(..)
+ if (rank (a) .ne. 0) stop 141
+ if (size (lbound (a)) .ne. 0) stop 142
+ if (size (ubound (a)) .ne. 0) stop 143
+ end subroutine
+
+ subroutine test1 (a)
+ integer :: a(*)
+
+ call testit (a)
+ end subroutine
+
+ subroutine test3 (a, l1, u1, l2, u2)
+ implicit none
+ integer :: l1, u1, l2, u2
+ integer :: a(l1:u1, l2:u2, *)
+
+ call testit (a)
+ end subroutine
+
+end program
diff --git a/gcc/testsuite/lib/target-supports.exp b/gcc/testsuite/lib/target-supports.exp
index 723c8eadbd9..b9417719990 100644
--- a/gcc/testsuite/lib/target-supports.exp
+++ b/gcc/testsuite/lib/target-supports.exp
@@ -1576,6 +1576,22 @@ proc check_effective_target_fortran_real_10 { } {
}]
}
+# Return 1 if the target supports Fortran real kind C_FLOAT128,
+# 0 otherwise. This differs from check_effective_target_fortran_real_16
+# because __float128 has the additional requirement that it be the
+# 128-bit IEEE encoding; even if __float128 is available in C, it may not
+# have a corresponding Fortran kind on targets (PowerPC) that use some
+# other encoding for long double/TFmode/real(16).
+proc check_effective_target_fortran_real_c_float128 { } {
+ return [check_no_compiler_messages fortran_real_c_float128 executable {
+ ! Fortran
+ use iso_c_binding
+ real(kind=c_float128) :: x
+ x = cos (x)
+ end
+ }]
+}
+
# Return 1 if the target supports Fortran's IEEE modules,
# 0 otherwise.
#
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-09-18 5:31 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-09-18 5:31 [gcc/devel/omp/gcc-11] Fortran: TS 29113 testsuite Sandra Loosemore
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).