From cb17b5054118ec0f727956fd6e034b577b5e261c Mon Sep 17 00:00:00 2001 From: Sandra Loosemore Date: Wed, 30 Jun 2021 20:03:27 -0700 Subject: [PATCH] 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 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. --- .../c-interop/allocatable-dummy-c.c | 54 +++ .../c-interop/allocatable-dummy.f90 | 98 +++++ .../allocatable-optional-pointer.f90 | 23 ++ .../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 ++ .../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 +++ .../c-interop/assumed-type-dummy.f90 | 84 ++++ .../gfortran.dg/c-interop/c-interop.exp | 57 +++ .../gfortran.dg/c-interop/c1255-1.f90 | 83 ++++ .../gfortran.dg/c-interop/c1255-2.f90 | 106 +++++ .../gfortran.dg/c-interop/c1255a.f90 | 40 ++ .../gfortran.dg/c-interop/c407a-1.f90 | 55 +++ .../gfortran.dg/c-interop/c407a-2.f90 | 88 ++++ .../gfortran.dg/c-interop/c407b-1.f90 | 107 +++++ .../gfortran.dg/c-interop/c407b-2.f90 | 150 +++++++ .../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 ++ .../gfortran.dg/c-interop/c535a-1.f90 | 65 +++ .../gfortran.dg/c-interop/c535a-2.f90 | 78 ++++ .../gfortran.dg/c-interop/c535b-1.f90 | 333 +++++++++++++++ .../gfortran.dg/c-interop/c535b-2.f90 | 387 ++++++++++++++++++ .../gfortran.dg/c-interop/c535b-3.f90 | 79 ++++ .../gfortran.dg/c-interop/c535c-1.f90 | 87 ++++ .../gfortran.dg/c-interop/c535c-2.f90 | 74 ++++ .../gfortran.dg/c-interop/c535c-3.f90 | 73 ++++ .../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 ++++ .../c-interop/cf-out-descriptor-1-c.c | 87 ++++ .../c-interop/cf-out-descriptor-1.f90 | 174 ++++++++ .../c-interop/cf-out-descriptor-2-c.c | 87 ++++ .../c-interop/cf-out-descriptor-2.f90 | 157 +++++++ .../c-interop/cf-out-descriptor-3-c.c | 108 +++++ .../c-interop/cf-out-descriptor-3.f90 | 134 ++++++ .../c-interop/cf-out-descriptor-4-c.c | 175 ++++++++ .../c-interop/cf-out-descriptor-4.f90 | 207 ++++++++++ .../c-interop/cf-out-descriptor-5-c.c | 31 ++ .../c-interop/cf-out-descriptor-5.f90 | 48 +++ .../c-interop/cf-out-descriptor-6-c.c | 42 ++ .../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 ++++++++ .../c-interop/deferred-character-1.f90 | 76 ++++ .../c-interop/deferred-character-2.f90 | 55 +++ .../gfortran.dg/c-interop/dump-descriptors.c | 195 +++++++++ .../gfortran.dg/c-interop/dump-descriptors.h | 12 + .../gfortran.dg/c-interop/establish-c.c | 134 ++++++ .../c-interop/establish-errors-c.c | 120 ++++++ .../c-interop/establish-errors.f90 | 30 ++ .../gfortran.dg/c-interop/establish.f90 | 35 ++ .../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 ++ .../c-interop/fc-out-descriptor-1-c.c | 52 +++ .../c-interop/fc-out-descriptor-1.f90 | 66 +++ .../c-interop/fc-out-descriptor-2-c.c | 52 +++ .../c-interop/fc-out-descriptor-2.f90 | 66 +++ .../c-interop/fc-out-descriptor-3-c.c | 71 ++++ .../c-interop/fc-out-descriptor-3.f90 | 59 +++ .../c-interop/fc-out-descriptor-4-c.c | 96 +++++ .../c-interop/fc-out-descriptor-4.f90 | 75 ++++ .../c-interop/fc-out-descriptor-5-c.c | 30 ++ .../c-interop/fc-out-descriptor-5.f90 | 35 ++ .../c-interop/fc-out-descriptor-6-c.c | 50 +++ .../c-interop/fc-out-descriptor-6.f90 | 49 +++ .../c-interop/fc-out-descriptor-7-c.c | 136 ++++++ .../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 ++++ .../gfortran.dg/c-interop/note-5-3.f90 | 55 +++ .../gfortran.dg/c-interop/note-5-4-c.c | 10 + .../gfortran.dg/c-interop/note-5-4.f90 | 63 +++ .../gfortran.dg/c-interop/optional-c.c | 82 ++++ .../gfortran.dg/c-interop/optional.f90 | 114 ++++++ .../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 ++ .../gfortran.dg/c-interop/section-1-c.c | 135 ++++++ .../gfortran.dg/c-interop/section-1.f90 | 71 ++++ .../gfortran.dg/c-interop/section-1p.f90 | 75 ++++ .../gfortran.dg/c-interop/section-2-c.c | 175 ++++++++ .../gfortran.dg/c-interop/section-2.f90 | 102 +++++ .../gfortran.dg/c-interop/section-2p.f90 | 104 +++++ .../gfortran.dg/c-interop/section-3-c.c | 235 +++++++++++ .../gfortran.dg/c-interop/section-3.f90 | 103 +++++ .../gfortran.dg/c-interop/section-3p.f90 | 127 ++++++ .../gfortran.dg/c-interop/section-4-c.c | 101 +++++ .../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 ++ .../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 ++ .../gfortran.dg/c-interop/select.f90 | 18 + .../gfortran.dg/c-interop/setpointer-c.c | 78 ++++ .../c-interop/setpointer-errors-c.c | 127 ++++++ .../c-interop/setpointer-errors.f90 | 28 ++ .../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 +++++++ .../c-interop/typecodes-array-char-c.c | 35 ++ .../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 ++ .../c-interop/typecodes-sanity-c.c | 179 ++++++++ .../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 ++ .../gfortran.dg/c-interop/ubound.f90 | 129 ++++++ gcc/testsuite/lib/target-supports.exp | 16 + 175 files changed, 13731 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/allocatable-optional-pointer.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/allocate-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/allocate-errors-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/allocate-errors.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/allocate.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-5.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-6.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-7.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-8.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/assumed-type-dummy.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c-interop.exp create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c1255a.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c407a-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c407a-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c407b-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c516.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c524a.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c535a-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c535a-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c535b-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c535b-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-1-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-2-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-3-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-4-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-6-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-6.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-7-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-7.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-8-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-8.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-1-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-2-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/contiguous-1-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/contiguous-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/contiguous-2-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/contiguous-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/contiguous-3-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/contiguous-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/deferred-character-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/deferred-character-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/dump-descriptors.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/dump-descriptors.h create mode 100644 gcc/testsuite/gfortran.dg/c-interop/establish-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/establish-errors-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/establish-errors.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/establish.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/explicit-interface.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-1-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-2-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-4-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-8-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-8.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-9-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-9.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-1-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-2-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-3-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-4-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-5-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-5.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-6-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-6.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-7-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-7.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-5.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-6.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/ff-descriptor-7.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/note-5-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/note-5-4-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/note-5-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/optional-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/optional.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/rank-class.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/rank.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/removed-restrictions-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/section-1-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/section-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/section-1p.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/section-2-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/section-2.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/section-2p.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/section-3-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/section-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/section-3p.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/section-4-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/section-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/section-errors-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/section-errors.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/select-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/select-errors-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/select-errors.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/select.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/setpointer-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/setpointer-errors-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/setpointer-errors.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/setpointer.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/shape.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/size.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/tkr.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-array-basic-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-array-basic.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-array-char.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-array-float128.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-array-int128-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-array-int128.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-array-longdouble-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-array-longdouble.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-sanity-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-sanity.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-basic.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-float128.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-int128.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble-c.c create mode 100644 gcc/testsuite/gfortran.dg/c-interop/typecodes-scalar-longdouble.f90 create mode 100644 gcc/testsuite/gfortran.dg/c-interop/ubound.f90 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 +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 +# . + +# 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 +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 + +#include +#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 + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include +#include +#include "dump-descriptors.h" + +void +dump_CFI_cdesc_t (CFI_cdesc_t *d) +{ + fprintf (stderr, "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, ""); +} + +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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 + +#include +#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 + +#include +#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 + +#include +#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 + +#include +#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 + +#include +#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 + +#include +#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 + +#include +#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 + +#include +#include "dump-descriptors.h" +#include + +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 + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 + +#include +#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 +#include + +#include +#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 + +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 +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include + +#include +#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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include + +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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 +#include +#include +#include + +#include +#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 0e877bcdba2..ad8f01152f2 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. #