procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: TS 29113 testsuite

Browse source 
Add tests to exercise features added to Fortran via TS 29113, "Further
Interoperability of Fortran with C":

https://wg5-fortran.org/N1901-N1950/N1942.pdf

2021-09-01  Sandra Loosemore  <sandra@codesourcery.com>

	gcc/testsuite/
	* gfortran.dg/c-interop/allocatable-dummy-c.c: New file.
	* gfortran.dg/c-interop/allocatable-dummy.f90: New file.
	* gfortran.dg/c-interop/allocatable-optional-pointer.f90: New file.
	* gfortran.dg/c-interop/allocate-c.c: New file.
	* gfortran.dg/c-interop/allocate-errors-c.c: New file.
	* gfortran.dg/c-interop/allocate-errors.f90: New file.
	* gfortran.dg/c-interop/allocate.f90: New file.
	* gfortran.dg/c-interop/argument-association-assumed-rank-1.f90:
	New file.
	* gfortran.dg/c-interop/argument-association-assumed-rank-2.f90:
	New file.
	* gfortran.dg/c-interop/argument-association-assumed-rank-3.f90:
	New file.
	* gfortran.dg/c-interop/argument-association-assumed-rank-4.f90:
	New file.
	* gfortran.dg/c-interop/argument-association-assumed-rank-5.f90:
	New file.
	* gfortran.dg/c-interop/argument-association-assumed-rank-6.f90:
	New file.
	* gfortran.dg/c-interop/argument-association-assumed-rank-7.f90:
	New file.
	* gfortran.dg/c-interop/argument-association-assumed-rank-8.f90:
	New file.
	* gfortran.dg/c-interop/assumed-type-dummy.f90: New file.
	* gfortran.dg/c-interop/c-interop.exp: New file.
	* gfortran.dg/c-interop/c1255-1.f90: New file.
	* gfortran.dg/c-interop/c1255-2.f90: New file.
	* gfortran.dg/c-interop/c1255a.f90: New file.
	* gfortran.dg/c-interop/c407a-1.f90: New file.
	* gfortran.dg/c-interop/c407a-2.f90: New file.
	* gfortran.dg/c-interop/c407b-1.f90: New file.
	* gfortran.dg/c-interop/c407b-2.f90: New file.
	* gfortran.dg/c-interop/c407c-1.f90: New file.
	* gfortran.dg/c-interop/c516.f90: New file.
	* gfortran.dg/c-interop/c524a.f90: New file.
	* gfortran.dg/c-interop/c535a-1.f90: New file.
	* gfortran.dg/c-interop/c535a-2.f90: New file.
	* gfortran.dg/c-interop/c535b-1.f90: New file.
	* gfortran.dg/c-interop/c535b-2.f90: New file.
	* gfortran.dg/c-interop/c535b-3.f90: New file.
	* gfortran.dg/c-interop/c535c-1.f90: New file.
	* gfortran.dg/c-interop/c535c-2.f90: New file.
	* gfortran.dg/c-interop/c535c-3.f90: New file.
	* gfortran.dg/c-interop/c535c-4.f90: New file.
	* gfortran.dg/c-interop/cf-descriptor-1-c.c: New file.
	* gfortran.dg/c-interop/cf-descriptor-1.f90: New file.
	* gfortran.dg/c-interop/cf-descriptor-2-c.c: New file.
	* gfortran.dg/c-interop/cf-descriptor-2.f90: New file.
	* gfortran.dg/c-interop/cf-descriptor-3-c.c: New file.
	* gfortran.dg/c-interop/cf-descriptor-3.f90: New file.
	* gfortran.dg/c-interop/cf-descriptor-4-c.c: New file.
	* gfortran.dg/c-interop/cf-descriptor-4.f90: New file.
	* gfortran.dg/c-interop/cf-descriptor-5-c.c: New file.
	* gfortran.dg/c-interop/cf-descriptor-5.f90: New file.
	* gfortran.dg/c-interop/cf-descriptor-6-c.c: New file.
	* gfortran.dg/c-interop/cf-descriptor-6.f90: New file.
	* gfortran.dg/c-interop/cf-descriptor-7-c.c: New file.
	* gfortran.dg/c-interop/cf-descriptor-7.f90: New file.
	* gfortran.dg/c-interop/cf-descriptor-8-c.c: New file.
	* gfortran.dg/c-interop/cf-descriptor-8.f90: New file.
	* gfortran.dg/c-interop/cf-out-descriptor-1-c.c: New file.
	* gfortran.dg/c-interop/cf-out-descriptor-1.f90: New file.
	* gfortran.dg/c-interop/cf-out-descriptor-2-c.c: New file.
	* gfortran.dg/c-interop/cf-out-descriptor-2.f90: New file.
	* gfortran.dg/c-interop/cf-out-descriptor-3-c.c: New file.
	* gfortran.dg/c-interop/cf-out-descriptor-3.f90: New file.
	* gfortran.dg/c-interop/cf-out-descriptor-4-c.c: New file.
	* gfortran.dg/c-interop/cf-out-descriptor-4.f90: New file.
	* gfortran.dg/c-interop/cf-out-descriptor-5-c.c: New file.
	* gfortran.dg/c-interop/cf-out-descriptor-5.f90: New file.
	* gfortran.dg/c-interop/cf-out-descriptor-6-c.c: New file.
	* gfortran.dg/c-interop/cf-out-descriptor-6.f90: New file.
	* gfortran.dg/c-interop/contiguous-1-c.c: New file.
	* gfortran.dg/c-interop/contiguous-1.f90: New file.
	* gfortran.dg/c-interop/contiguous-2-c.c: New file.
	* gfortran.dg/c-interop/contiguous-2.f90: New file.
	* gfortran.dg/c-interop/contiguous-3-c.c: New file.
	* gfortran.dg/c-interop/contiguous-3.f90: New file.
	* gfortran.dg/c-interop/deferred-character-1.f90: New file.
	* gfortran.dg/c-interop/deferred-character-2.f90: New file.
	* gfortran.dg/c-interop/dump-descriptors.c: New file.
	* gfortran.dg/c-interop/dump-descriptors.h: New file.
	* gfortran.dg/c-interop/establish-c.c: New file.
	* gfortran.dg/c-interop/establish-errors-c.c: New file.
	* gfortran.dg/c-interop/establish-errors.f90: New file.
	* gfortran.dg/c-interop/establish.f90: New file.
	* gfortran.dg/c-interop/explicit-interface.f90: New file.
	* gfortran.dg/c-interop/fc-descriptor-1-c.c: New file.
	* gfortran.dg/c-interop/fc-descriptor-1.f90: New file.
	* gfortran.dg/c-interop/fc-descriptor-2-c.c: New file.
	* gfortran.dg/c-interop/fc-descriptor-2.f90: New file.
	* gfortran.dg/c-interop/fc-descriptor-3-c.c: New file.
	* gfortran.dg/c-interop/fc-descriptor-3.f90: New file.
	* gfortran.dg/c-interop/fc-descriptor-4-c.c: New file.
	* gfortran.dg/c-interop/fc-descriptor-4.f90: New file.
	* gfortran.dg/c-interop/fc-descriptor-5-c.c: New file.
	* gfortran.dg/c-interop/fc-descriptor-5.f90: New file.
	* gfortran.dg/c-interop/fc-descriptor-6-c.c: New file.
	* gfortran.dg/c-interop/fc-descriptor-6.f90: New file.
	* gfortran.dg/c-interop/fc-descriptor-7-c.c: New file.
	* gfortran.dg/c-interop/fc-descriptor-7.f90: New file.
	* gfortran.dg/c-interop/fc-descriptor-8-c.c: New file.
	* gfortran.dg/c-interop/fc-descriptor-8.f90: New file.
	* gfortran.dg/c-interop/fc-descriptor-9-c.c: New file.
	* gfortran.dg/c-interop/fc-descriptor-9.f90: New file.
	* gfortran.dg/c-interop/fc-out-descriptor-1-c.c: New file.
	* gfortran.dg/c-interop/fc-out-descriptor-1.f90: New file.
	* gfortran.dg/c-interop/fc-out-descriptor-2-c.c: New file.
	* gfortran.dg/c-interop/fc-out-descriptor-2.f90: New file.
	* gfortran.dg/c-interop/fc-out-descriptor-3-c.c: New file.
	* gfortran.dg/c-interop/fc-out-descriptor-3.f90: New file.
	* gfortran.dg/c-interop/fc-out-descriptor-4-c.c: New file.
	* gfortran.dg/c-interop/fc-out-descriptor-4.f90: New file.
	* gfortran.dg/c-interop/fc-out-descriptor-5-c.c: New file.
	* gfortran.dg/c-interop/fc-out-descriptor-5.f90: New file.
	* gfortran.dg/c-interop/fc-out-descriptor-6-c.c: New file.
	* gfortran.dg/c-interop/fc-out-descriptor-6.f90: New file.
	* gfortran.dg/c-interop/fc-out-descriptor-7-c.c: New file.
	* gfortran.dg/c-interop/fc-out-descriptor-7.f90: New file.
	* gfortran.dg/c-interop/ff-descriptor-1.f90: New file.
	* gfortran.dg/c-interop/ff-descriptor-2.f90: New file.
	* gfortran.dg/c-interop/ff-descriptor-3.f90: New file.
	* gfortran.dg/c-interop/ff-descriptor-4.f90: New file.
	* gfortran.dg/c-interop/ff-descriptor-5.f90: New file.
	* gfortran.dg/c-interop/ff-descriptor-6.f90: New file.
	* gfortran.dg/c-interop/ff-descriptor-7.f90: New file.
	* gfortran.dg/c-interop/note-5-3.f90: New file.
	* gfortran.dg/c-interop/note-5-4-c.c: New file.
	* gfortran.dg/c-interop/note-5-4.f90: New file.
	* gfortran.dg/c-interop/optional-c.c: New file.
	* gfortran.dg/c-interop/optional.f90: New file.
	* gfortran.dg/c-interop/rank-class.f90: New file.
	* gfortran.dg/c-interop/rank.f90: New file.
	* gfortran.dg/c-interop/removed-restrictions-1.f90: New file.
	* gfortran.dg/c-interop/removed-restrictions-2.f90: New file.
	* gfortran.dg/c-interop/removed-restrictions-3.f90: New file.
	* gfortran.dg/c-interop/removed-restrictions-4.f90: New file.
	* gfortran.dg/c-interop/section-1-c.c: New file.
	* gfortran.dg/c-interop/section-1.f90: New file.
	* gfortran.dg/c-interop/section-1p.f90: New file.
	* gfortran.dg/c-interop/section-2-c.c: New file.
	* gfortran.dg/c-interop/section-2.f90: New file.
	* gfortran.dg/c-interop/section-2p.f90: New file.
	* gfortran.dg/c-interop/section-3-c.c: New file.
	* gfortran.dg/c-interop/section-3.f90: New file.
	* gfortran.dg/c-interop/section-3p.f90: New file.
	* gfortran.dg/c-interop/section-4-c.c: New file.
	* gfortran.dg/c-interop/section-4.f90: New file.
	* gfortran.dg/c-interop/section-errors-c.c: New file.
	* gfortran.dg/c-interop/section-errors.f90: New file.
	* gfortran.dg/c-interop/select-c.c: New file.
	* gfortran.dg/c-interop/select-errors-c.c: New file.
	* gfortran.dg/c-interop/select-errors.f90: New file.
	* gfortran.dg/c-interop/select.f90: New file.
	* gfortran.dg/c-interop/setpointer-c.c: New file.
	* gfortran.dg/c-interop/setpointer-errors-c.c: New file.
	* gfortran.dg/c-interop/setpointer-errors.f90: New file.
	* gfortran.dg/c-interop/setpointer.f90: New file.
	* gfortran.dg/c-interop/shape.f90: New file.
	* gfortran.dg/c-interop/size.f90: New file.
	* gfortran.dg/c-interop/tkr.f90: New file.
	* gfortran.dg/c-interop/typecodes-array-basic-c.c: New file.
	* gfortran.dg/c-interop/typecodes-array-basic.f90: New file.
	* gfortran.dg/c-interop/typecodes-array-char-c.c: New file.
	* gfortran.dg/c-interop/typecodes-array-char.f90: New file.
	* gfortran.dg/c-interop/typecodes-array-float128-c.c: New file.
	* gfortran.dg/c-interop/typecodes-array-float128.f90: New file.
	* gfortran.dg/c-interop/typecodes-array-int128-c.c: New file.
	* gfortran.dg/c-interop/typecodes-array-int128.f90: New file.
	* gfortran.dg/c-interop/typecodes-array-longdouble-c.c: New file.
	* gfortran.dg/c-interop/typecodes-array-longdouble.f90: New file.
	* gfortran.dg/c-interop/typecodes-sanity-c.c: New file.
	* gfortran.dg/c-interop/typecodes-sanity.f90: New file.
	* gfortran.dg/c-interop/typecodes-scalar-basic-c.c: New file.
	* gfortran.dg/c-interop/typecodes-scalar-basic.f90: New file.
	* gfortran.dg/c-interop/typecodes-scalar-float128-c.c: New file.
	* gfortran.dg/c-interop/typecodes-scalar-float128.f90: New file.
	* gfortran.dg/c-interop/typecodes-scalar-int128-c.c: New file.
	* gfortran.dg/c-interop/typecodes-scalar-int128.f90: New file.
	* gfortran.dg/c-interop/typecodes-scalar-longdouble-c.c: New file.
	* gfortran.dg/c-interop/typecodes-scalar-longdouble.f90: New file.
	* gfortran.dg/c-interop/ubound.f90: New file.
	* lib/target-supports.exp
	(check_effective_target_fortran_real_c_float128): New function.
This commit is contained in:
Sandra Loosemore 2021-06-30 20:03:27 -07:00
parent 89cf858571
commit cb17b50541
175 changed files with 13731 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

54
gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy-c.c Normal file
View file

@ -0,0 +1,54 @@
#include <stdlib.h>
#include <stddef.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
struct t {
float xyz[3];
int id;
};
extern void testit_f_bind_c (CFI_cdesc_t *a, float x, float y, float z);
extern void testit_c (CFI_cdesc_t *a, float x, float y, float z);
void testit_c (CFI_cdesc_t *a, float x, float y, float z)
{
struct t *tp;
/* Check that the allocatable dummy is unallocated on entry and do
some other sanity checks. */
dump_CFI_cdesc_t (a);
if (a->attribute != CFI_attribute_allocatable)
abort ();
if (a->rank)
abort ();
if (a->base_addr)
abort ();
/* Allocate and initialize the output argument. */
CFI_allocate (a, NULL, NULL, 0);
if (!a->base_addr)
abort ();
tp = (struct t *) CFI_address (a, NULL);
tp->id = 42;
tp->xyz[0] = 0.0;
tp->xyz[1] = 0.0;
tp->xyz[2] = 0.0;
/* Now call the Fortran function, which is supposed to automatically
deallocate the object we just created above and point the descriptor
at a different object. */
testit_f_bind_c (a, x, y, z);
/* Make sure we've got an allocated object, initialized as we
expect. */
if (!a->base_addr)
abort ();
tp = (struct t *) CFI_address (a, NULL);
if (tp->id != -1)
abort ();
if (tp->xyz[0] != x || tp->xyz[1] != y || tp->xyz[2] != z)
abort ();
}

98
gcc/testsuite/gfortran.dg/c-interop/allocatable-dummy.f90 Normal file
View file

@ -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

23
gcc/testsuite/gfortran.dg/c-interop/allocatable-optional-pointer.f90 Normal file
View file

@ -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

168
gcc/testsuite/gfortran.dg/c-interop/allocate-c.c Normal file
View file

@ -0,0 +1,168 @@
#include <stdlib.h>
#include <stdint.h>
#include <stdio.h>
#include <string.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
struct s {
int i;
double d;
};
/* External entry point. */
extern void ctest (void);
void
ctest (void)
{
CFI_CDESC_T(3) desc;
CFI_cdesc_t *dv = (CFI_cdesc_t *) &desc;
CFI_index_t ex[3], lb[3], ub[3];
CFI_index_t sm;
int i;
/* Allocate and deallocate a scalar. */
sm = sizeof (struct s);
check_CFI_status ("CFI_establish",
CFI_establish (dv, NULL, CFI_attribute_allocatable,
CFI_type_struct, sm,
0, NULL));
check_CFI_status ("CFI_allocate",
CFI_allocate (dv, NULL, NULL, 69));
dump_CFI_cdesc_t (dv);
if (dv->base_addr == NULL)
abort ();
/* The elem_len argument only overrides the initial value in the
descriptor for character types. */
if (dv->elem_len != sm)
abort ();
check_CFI_status ("CFI_deallocate",
CFI_deallocate (dv));
/* The base_addr member of the C descriptor becomes a null pointer. */
if (dv->base_addr != NULL)
abort ();
/* Try an array. We are going to test the requirement that:
The supplied lower and upper bounds override any current
dimension information in the C descriptor.
so we'll stuff different values in the descriptor to start with. */
ex[0] = 3;
ex[1] = 4;
ex[2] = 5;
check_CFI_status ("CFI_establish",
CFI_establish (dv, NULL, CFI_attribute_pointer,
CFI_type_double, 0, 3, ex));
lb[0] = 1;
lb[1] = 2;
lb[2] = 3;
ub[0] = 10;
ub[1] = 5;
ub[2] = 10;
sm = sizeof (double);
check_CFI_status ("CFI_allocate",
CFI_allocate (dv, lb, ub, 20));
dump_CFI_cdesc_t (dv);
if (dv->base_addr == NULL)
abort ();
/* The element sizes passed to both CFI_establish and CFI_allocate should
have been ignored in favor of using the constant size of the type. */
if (dv->elem_len != sm)
abort ();
/* Check extents and strides; we expect the allocated array to
be contiguous so the stride computation should be straightforward
no matter what the lower bound is. */
for (i = 0; i < 3; i++)
{
CFI_index_t extent = ub[i] - lb[i] + 1;
if (dv->dim[i].lower_bound != lb[i])
abort ();
if (dv->dim[i].extent != extent)
abort ();
/* pr93524 */
if (dv->dim[i].sm != sm)
abort ();
sm *= extent;
}
check_CFI_status ("CFI_deallocate",
CFI_deallocate (dv));
if (dv->base_addr != NULL)
abort ();
/* Similarly for a character array, except that we expect the
elem_len provided to CFI_allocate to prevail. We set the elem_len
to the same size as the array element in the previous example, so
the bounds and strides should all be the same. */
ex[0] = 3;
ex[1] = 4;
ex[2] = 5;
check_CFI_status ("CFI_establish",
CFI_establish (dv, NULL, CFI_attribute_allocatable,
CFI_type_char, 4, 3, ex));
lb[0] = 1;
lb[1] = 2;
lb[2] = 3;
ub[0] = 10;
ub[1] = 5;
ub[2] = 10;
sm = sizeof (double);
check_CFI_status ("CFI_allocate",
CFI_allocate (dv, lb, ub, sm));
dump_CFI_cdesc_t (dv);
if (dv->base_addr == NULL)
abort ();
if (dv->elem_len != sm)
abort ();
/* Check extents and strides; we expect the allocated array to
be contiguous so the stride computation should be straightforward
no matter what the lower bound is. */
for (i = 0; i < 3; i++)
{
CFI_index_t extent = ub[i] - lb[i] + 1;
if (dv->dim[i].lower_bound != lb[i])
abort ();
if (dv->dim[i].extent != extent)
abort ();
/* pr93524 */
if (dv->dim[i].sm != sm)
abort ();
sm *= extent;
}
check_CFI_status ("CFI_deallocate",
CFI_deallocate (dv));
if (dv->base_addr != NULL)
abort ();
/* Signed char is not a Fortran character type. Here we expect it to
ignore the elem_len argument and use the size of the type. */
ex[0] = 3;
ex[1] = 4;
ex[2] = 5;
check_CFI_status ("CFI_establish",
CFI_establish (dv, NULL, CFI_attribute_allocatable,
CFI_type_signed_char, 4, 3, ex));
lb[0] = 1;
lb[1] = 2;
lb[2] = 3;
ub[0] = 10;
ub[1] = 5;
ub[2] = 10;
sm = sizeof (double);
check_CFI_status ("CFI_allocate",
CFI_allocate (dv, lb, ub, sm));
dump_CFI_cdesc_t (dv);
if (dv->base_addr == NULL)
abort ();
if (dv->elem_len != sizeof (signed char))
abort ();
check_CFI_status ("CFI_deallocate",
CFI_deallocate (dv));
if (dv->base_addr != NULL)
abort ();
}

109
gcc/testsuite/gfortran.dg/c-interop/allocate-errors-c.c Normal file
View file

@ -0,0 +1,109 @@
#include <stdlib.h>
#include <stdint.h>
#include <stdio.h>
#include <string.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
struct s {
int i;
double d;
};
static long buf[5][4][3];
/* External entry point. */
extern void ctest (void);
void
ctest (void)
{
int bad = 0;
int status;
CFI_CDESC_T(3) desc;
CFI_cdesc_t *dv = (CFI_cdesc_t *) &desc;
CFI_index_t ex[3], lb[3], ub[3];
CFI_index_t sm;
/* On entry, the base_addr member of the C descriptor shall be a null
pointer. */
sm = sizeof (struct s);
check_CFI_status ("CFI_establish",
CFI_establish (dv, NULL, CFI_attribute_allocatable,
CFI_type_struct, sm,
0, NULL));
check_CFI_status ("CFI_allocate",
CFI_allocate (dv, NULL, NULL, 69));
status = CFI_allocate (dv, NULL, NULL, 42);
if (status == CFI_SUCCESS)
{
fprintf (stderr,
"no error for CFI_allocate of already-allocated object\n");
bad ++;
}
check_CFI_status ("CFI_deallocate",
CFI_deallocate (dv));
/* The attribute member of the C descriptor shall have a value of
CFI_attribute_allocatable or CFI_attribute_pointer. */
ex[0] = 3;
ex[1] = 4;
ex[2] = 5;
check_CFI_status ("CFI_establish",
CFI_establish (dv, NULL, CFI_attribute_other,
CFI_type_long, 0, 3, ex));
lb[0] = 1;
lb[1] = 2;
lb[2] = 3;
ub[0] = 10;
ub[1] = 5;
ub[2] = 10;
sm = sizeof (long);
status = CFI_allocate (dv, lb, ub, 20);
if (status == CFI_SUCCESS)
{
fprintf (stderr,
"no error for CFI_allocate of CFI_attribute_other object\n");
bad ++;
}
/* dv shall be the address of a C descriptor describing the object.
It shall have been allocated using the same mechanism as the
Fortran ALLOCATE statement. */
ex[0] = 3;
ex[1] = 4;
ex[2] = 5;
check_CFI_status ("CFI_establish",
CFI_establish (dv, NULL, CFI_attribute_pointer,
CFI_type_long, 0, 3, ex));
status = CFI_deallocate (dv);
if (status == CFI_SUCCESS)
{
fprintf (stderr,
"no error for CFI_deallocate with null pointer\n");
bad ++;
}
/* This variant is disabled. In theory it should be possible for
the memory allocator to easily check for pointers outside the
heap region, but libfortran just calls free() which has no provision
for returning an error, and there is no other standard C interface
to check the validity of a pointer in the C heap either. */
#if 0
check_CFI_status ("CFI_establish",
CFI_establish (dv, buf, CFI_attribute_pointer,
CFI_type_long, 0, 3, ex));
status = CFI_deallocate (dv);
if (status == CFI_SUCCESS)
{
fprintf (stderr,
"no error for CFI_deallocate with non-allocated pointer\n");
bad ++;
}
#endif
if (bad)
abort ();
}

27
gcc/testsuite/gfortran.dg/c-interop/allocate-errors.f90 Normal file
View file

@ -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

19
gcc/testsuite/gfortran.dg/c-interop/allocate.f90 Normal file
View file

@ -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

31
gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-1.f90 Normal file
View file

@ -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

48
gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-2.f90 Normal file
View file

@ -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

51
gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-3.f90 Normal file
View file

@ -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

50
gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-4.f90 Normal file
View file

@ -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

31
gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-5.f90 Normal file
View file

@ -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

48
gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-6.f90 Normal file
View file

@ -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

51
gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-7.f90 Normal file
View file

@ -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

50
gcc/testsuite/gfortran.dg/c-interop/argument-association-assumed-rank-8.f90 Normal file
View file

@ -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

84
gcc/testsuite/gfortran.dg/c-interop/assumed-type-dummy.f90 Normal file
View file

@ -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

57
gcc/testsuite/gfortran.dg/c-interop/c-interop.exp Normal file
View file

@ -0,0 +1,57 @@
# Copyright (C) 2005-2021 Free Software Foundation, Inc.
#
# This file is part of GCC.
#
# GCC is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3, or (at your option)
# any later version.
#
# GCC is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with GCC; see the file COPYING3. If not see
# <http://www.gnu.org/licenses/>.
# GCC testsuite that uses the `dg.exp' driver.
# Load support procs.
load_lib gfortran-dg.exp
# Initialize `dg'.
dg-init
global gfortran_test_path
global gfortran_aux_module_flags
set gfortran_test_path $srcdir/$subdir
set gfortran_aux_module_flags "-Werror -std=f2018"
proc dg-compile-aux-modules { args } {
global gfortran_test_path
global gfortran_aux_module_flags
if { [llength $args] != 2 } {
error "dg-compile-aux-modules: needs one argument"
return
}
set level [info level]
if { [info procs dg-save-unknown] != [list] } {
rename dg-save-unknown dg-save-unknown-level-$level
}
dg-test $gfortran_test_path/[lindex $args 1] "" $gfortran_aux_module_flags
# cleanup-modules is intentionally not invoked here.
if { [info procs dg-save-unknown-level-$level] != [list] } {
rename dg-save-unknown-level-$level dg-save-unknown
}
}
# Main loop.
gfortran-dg-runtest [lsort \
[find $srcdir/$subdir *.\[fF\]{,90,95,03,08} ] ] "" "-Werror"
# All done.
dg-finish

83
gcc/testsuite/gfortran.dg/c-interop/c1255-1.f90 Normal file
View file

@ -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

106
gcc/testsuite/gfortran.dg/c-interop/c1255-2.f90 Normal file
View file

@ -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

40
gcc/testsuite/gfortran.dg/c-interop/c1255a.f90 Normal file
View file

@ -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

55
gcc/testsuite/gfortran.dg/c-interop/c407a-1.f90 Normal file
View file

@ -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

88
gcc/testsuite/gfortran.dg/c-interop/c407a-2.f90 Normal file
View file

@ -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

107
gcc/testsuite/gfortran.dg/c-interop/c407b-1.f90 Normal file
View file

@ -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

150
gcc/testsuite/gfortran.dg/c-interop/c407b-2.f90 Normal file
View file

@ -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

63
gcc/testsuite/gfortran.dg/c-interop/c407c-1.f90 Normal file
View file

@ -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.

67
gcc/testsuite/gfortran.dg/c-interop/c516.f90 Normal file
View file

@ -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

30
gcc/testsuite/gfortran.dg/c-interop/c524a.f90 Normal file
View file

@ -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

65
gcc/testsuite/gfortran.dg/c-interop/c535a-1.f90 Normal file
View file

@ -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

78
gcc/testsuite/gfortran.dg/c-interop/c535a-2.f90 Normal file
View file

@ -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

333
gcc/testsuite/gfortran.dg/c-interop/c535b-1.f90 Normal file
View file

@ -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

387
gcc/testsuite/gfortran.dg/c-interop/c535b-2.f90 Normal file
View file

@ -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

79
gcc/testsuite/gfortran.dg/c-interop/c535b-3.f90 Normal file
View file

@ -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

87
gcc/testsuite/gfortran.dg/c-interop/c535c-1.f90 Normal file
View file

@ -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

74
gcc/testsuite/gfortran.dg/c-interop/c535c-2.f90 Normal file
View file

@ -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

73
gcc/testsuite/gfortran.dg/c-interop/c535c-3.f90 Normal file
View file

@ -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

73
gcc/testsuite/gfortran.dg/c-interop/c535c-4.f90 Normal file
View file

@ -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

91
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-1-c.c Normal file
View file

@ -0,0 +1,91 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a);
extern void ftest (CFI_cdesc_t *a, CFI_cdesc_t *b);
struct m {
int i;
int j;
};
#define imax 10
#define jmax 5
void
ctest (CFI_cdesc_t *a)
{
struct m bdata[imax][jmax];
CFI_CDESC_T(2) bdesc;
CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
int i, j;
CFI_index_t subscripts[2];
struct m* mp;
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
if (a->rank != 2)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
if (a->dim[0].lower_bound != 0)
abort ();
if (a->dim[0].extent != imax)
abort ();
if (a->dim[1].lower_bound != 0)
abort ();
if (a->dim[1].extent != jmax)
abort ();
/* Transpose a's contents into bdata. */
for (j = 0; j < jmax; j++)
{
subscripts[1] = j;
for (i = 0; i < imax; i++)
{
subscripts[0] = i;
mp = (struct m *) CFI_address (a, subscripts);
if (mp->i != i + 1)
abort ();
if (mp->j != j + 1)
abort ();
bdata[i][j].i = mp->i;
bdata[i][j].j = mp->j;
}
}
/* Fill in bdesc. */
subscripts[0] = jmax;
subscripts[1] = imax;
check_CFI_status ("CFI_establish",
CFI_establish (b, bdata, CFI_attribute_other,
CFI_type_struct,
sizeof (struct m), 2, subscripts));
/* Sanity checking to make sure the descriptor has been initialized
properly. */
dump_CFI_cdesc_t (b);
if (b->version != CFI_VERSION)
abort ();
if (b->rank != 2)
abort ();
if (b->attribute != CFI_attribute_other)
abort ();
if (b->dim[0].lower_bound != 0)
abort ();
if (b->dim[0].extent != jmax)
abort ();
if (b->dim[1].lower_bound != 0)
abort ();
if (b->dim[1].extent != imax)
abort ();
/* Call back into Fortran, passing both the a and b arrays. */
ftest (a, b);
}

66
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-1.f90 Normal file
View file

@ -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

91
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-2-c.c Normal file
View file

@ -0,0 +1,91 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a);
extern void ftest (CFI_cdesc_t *a, CFI_cdesc_t *b);
struct m {
int i;
int j;
};
#define imax 10
#define jmax 5
void
ctest (CFI_cdesc_t *a)
{
struct m bdata[imax][jmax];
CFI_CDESC_T(2) bdesc;
CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
int i, j;
CFI_index_t subscripts[2];
struct m* mp;
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
if (a->rank != 2)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
if (a->dim[0].lower_bound != 0)
abort ();
if (a->dim[0].extent != imax)
abort ();
if (a->dim[1].lower_bound != 0)
abort ();
if (a->dim[1].extent != jmax)
abort ();
/* Transpose a's contents into bdata. */
for (j = 0; j < jmax; j++)
{
subscripts[1] = j;
for (i = 0; i < imax; i++)
{
subscripts[0] = i;
mp = (struct m *) CFI_address (a, subscripts);
if (mp->i != i + 1)
abort ();
if (mp->j != j + 1)
abort ();
bdata[i][j].i = mp->i;
bdata[i][j].j = mp->j;
}
}
/* Fill in bdesc. */
subscripts[0] = jmax;
subscripts[1] = imax;
check_CFI_status ("CFI_establish",
CFI_establish (b, bdata, CFI_attribute_other,
CFI_type_struct,
sizeof (struct m), 2, subscripts));
/* Sanity checking to make sure the descriptor has been initialized
properly. */
dump_CFI_cdesc_t (b);
if (b->version != CFI_VERSION)
abort ();
if (b->rank != 2)
abort ();
if (b->attribute != CFI_attribute_other)
abort ();
if (b->dim[0].lower_bound != 0)
abort ();
if (b->dim[0].extent != jmax)
abort ();
if (b->dim[1].lower_bound != 0)
abort ();
if (b->dim[1].extent != imax)
abort ();
/* Call back into Fortran, passing both the a and b arrays. */
ftest (a, b);
}

82
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-2.f90 Normal file
View file

@ -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

92
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-3-c.c Normal file
View file

@ -0,0 +1,92 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (int imagic, int jmagic);
extern void ftest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp);
struct m {
int i;
int j;
};
void
ctest (int imagic, int jmagic)
{
CFI_CDESC_T(0) adesc;
CFI_CDESC_T(0) bdesc;
CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc;
CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
struct m* mp;
/* Create the descriptor for a, then sanity-check it. */
check_CFI_status ("CFI_establish",
CFI_establish (a, NULL, CFI_attribute_allocatable,
CFI_type_struct,
sizeof (struct m), 0, NULL));
dump_CFI_cdesc_t (a);
if (a->version != CFI_VERSION)
abort ();
if (a->rank != 0)
abort ();
if (a->attribute != CFI_attribute_allocatable)
abort ();
if (a->base_addr)
abort ();
if (a->elem_len != sizeof (struct m))
abort ();
/* Likewise for b. */
check_CFI_status ("CFI_establish",
CFI_establish (b, NULL, CFI_attribute_pointer,
CFI_type_struct,
sizeof (struct m), 0, NULL));
dump_CFI_cdesc_t (b);
if (b->version != CFI_VERSION)
abort ();
if (b->rank != 0)
abort ();
if (b->attribute != CFI_attribute_pointer)
abort ();
if (b->base_addr)
abort ();
if (b->elem_len != sizeof (struct m))
abort ();
/* Call back into Fortran, passing the unallocated descriptors. */
ftest (a, b, 0);
/* Allocate and initialize both variables, and try again. */
check_CFI_status ("CFI_allocate",
CFI_allocate (a, NULL, NULL, 0));
dump_CFI_cdesc_t (a);
if (!a->base_addr)
abort ();
if (a->elem_len != sizeof (struct m))
abort ();
((struct m *)a->base_addr)->i = imagic;
((struct m *)a->base_addr)->j = jmagic;
check_CFI_status ("CFI_allocate",
CFI_allocate (b, NULL, NULL, 0));
dump_CFI_cdesc_t (b);
if (!b->base_addr)
abort ();
if (b->elem_len != sizeof (struct m))
abort ();
((struct m *)b->base_addr)->i = imagic + 1;
((struct m *)b->base_addr)->j = jmagic + 1;
ftest (a, b, 1);
/* Deallocate both objects and try again. */
check_CFI_status ("CFI_deallocate", CFI_deallocate (a));
if (a->base_addr)
abort ();
check_CFI_status ("CFI_deallocate", CFI_deallocate (b));
if (b->base_addr)
abort ();
ftest (a, b, 0);
}

58
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-3.f90 Normal file
View file

@ -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

112
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-4-c.c Normal file
View file

@ -0,0 +1,112 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (int imagic, int jmagic);
extern void ftest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp);
struct m {
int i;
int j;
};
void
ctest (int imax, int jmax)
{
CFI_CDESC_T(2) adesc;
CFI_CDESC_T(2) bdesc;
CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc;
CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
struct m* mp;
CFI_index_t lower[2], upper[2], subscripts[2];
CFI_index_t i, j;
/* Create the descriptor for a, then sanity-check it. */
check_CFI_status ("CFI_establish",
CFI_establish (a, NULL, CFI_attribute_allocatable,
CFI_type_struct,
sizeof (struct m), 2, NULL));
dump_CFI_cdesc_t (a);
if (a->version != CFI_VERSION)
abort ();
if (a->rank != 2)
abort ();
if (a->attribute != CFI_attribute_allocatable)
abort ();
if (a->base_addr)
abort ();
if (a->elem_len != sizeof (struct m))
abort ();
/* Likewise for b. */
check_CFI_status ("CFI_establish",
CFI_establish (b, NULL, CFI_attribute_pointer,
CFI_type_struct,
sizeof (struct m), 2, NULL));
dump_CFI_cdesc_t (b);
if (b->version != CFI_VERSION)
abort ();
if (b->rank != 2)
abort ();
if (b->attribute != CFI_attribute_pointer)
abort ();
if (b->base_addr)
abort ();
if (b->elem_len != sizeof (struct m))
abort ();
/* Call back into Fortran, passing the unallocated descriptors. */
ftest (a, b, 0);
/* Allocate and initialize both variables, and try again. */
lower[0] = 1;
lower[1] = 1;
upper[0] = imax;
upper[1] = jmax;
check_CFI_status ("CFI_allocate",
CFI_allocate (a, lower, upper, 0));
dump_CFI_cdesc_t (a);
if (!a->base_addr)
abort ();
if (a->elem_len != sizeof (struct m))
abort ();
upper[0] = jmax;
upper[1] = imax;
check_CFI_status ("CFI_allocate",
CFI_allocate (b, lower, upper, 0));
dump_CFI_cdesc_t (b);
if (!b->base_addr)
abort ();
if (b->elem_len != sizeof (struct m))
abort ();
for (i = 1; i <= imax; i++)
for (j = 1; j <= jmax; j++)
{
subscripts[0] = i;
subscripts[1] = j;
mp = (struct m *) CFI_address (a, subscripts);
mp->i = i;
mp->j = j;
subscripts[0] = j;
subscripts[1] = i;
mp = (struct m *) CFI_address (b, subscripts);
mp->i = i;
mp->j = j;
}
ftest (a, b, 1);
/* Deallocate both objects and try again. */
check_CFI_status ("CFI_deallocate", CFI_deallocate (a));
if (a->base_addr)
abort ();
check_CFI_status ("CFI_deallocate", CFI_deallocate (b));
if (b->base_addr)
abort ();
ftest (a, b, 0);
}

73
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-4.f90 Normal file
View file

@ -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

36
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5-c.c Normal file
View file

@ -0,0 +1,36 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (int n);
extern void ftest (CFI_cdesc_t *a, int n);
void
ctest (int n)
{
CFI_CDESC_T(0) adesc;
CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc;
char *adata = (char *) alloca (n);
/* Fill in adesc. */
check_CFI_status ("CFI_establish",
CFI_establish (a, adata, CFI_attribute_other,
CFI_type_char, n, 0, NULL));
/* Sanity checking to make sure the descriptor has been initialized
properly. */
dump_CFI_cdesc_t (a);
if (a->version != CFI_VERSION)
abort ();
if (a->rank != 0)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
if (a->elem_len != n)
abort ();
/* Call back into Fortran. */
ftest (a, n);
}

31
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-5.f90 Normal file
View file

@ -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

81
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-6-c.c Normal file
View file

@ -0,0 +1,81 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a, int lb1, int lb2, int ub1, int ub2, int step1, int step2);
extern void ftest (CFI_cdesc_t *b);
struct m {
int i;
int j;
};
void
ctest (CFI_cdesc_t *a, int lb1, int lb2, int ub1, int ub2,
int step1, int step2)
{
CFI_CDESC_T(2) bdesc;
CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
CFI_index_t lb[2], ub[2], step[2];
int i, j;
fprintf (stderr, "got new bound info (%d:%d:%d, %d:%d:%d)\n",
lb1, ub1, step1, lb2, ub2, step2);
lb[0] = lb1 - 1;
lb[1] = lb2 - 1;
ub[0] = ub1 - 1;
ub[1] = ub2 - 1;
step[0] = step1;
step[1] = step2;
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
if (a->rank != 2)
abort ();
/* Fill in bdesc. */
check_CFI_status ("CFI_establish",
CFI_establish (b, NULL, CFI_attribute_pointer,
CFI_type_struct,
sizeof (struct m), 2, NULL));
check_CFI_status ("CFI_section",
CFI_section (b, a, lb, ub, step));
/* Sanity checking to make sure the descriptor has been initialized
properly. */
dump_CFI_cdesc_t (b);
if (b->version != CFI_VERSION)
abort ();
if (b->rank != 2)
abort ();
if (b->attribute != CFI_attribute_pointer)
abort ();
if (!b->base_addr)
abort ();
if (CFI_is_contiguous (b))
abort ();
for (j = b->dim[1].lower_bound;
j < b->dim[1].lower_bound + b->dim[1].extent;
j++)
{
for (i = b->dim[0].lower_bound;
i < b->dim[0].lower_bound + b->dim[0].extent;
i++)
{
CFI_index_t subscripts[2];
struct m *mp;
subscripts[0] = i;
subscripts[1] = j;
mp = (struct m *) CFI_address (b, subscripts);
fprintf (stderr, "b(%d,%d) = (%d,%d)\n", i, j, mp->i, mp->j);
}
}
/* Call back into Fortran. */
ftest (b);
}

72
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-6.f90 Normal file
View file

@ -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

81
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-7-c.c Normal file
View file

@ -0,0 +1,81 @@
#include <stdlib.h>
#include <stdio.h>
#include <stddef.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a);
extern void ftest (CFI_cdesc_t *iarray, CFI_cdesc_t *jarray);
struct m {
int i;
int j;
};
void
ctest (CFI_cdesc_t *a)
{
CFI_CDESC_T(2) idesc;
CFI_cdesc_t *iarray = (CFI_cdesc_t *) &idesc;
CFI_CDESC_T(2) jdesc;
CFI_cdesc_t *jarray = (CFI_cdesc_t *) &jdesc;
int i, j;
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
if (a->rank != 2)
abort ();
/* Fill in the new descriptors. */
check_CFI_status ("CFI_establish",
CFI_establish (iarray, NULL, CFI_attribute_pointer,
CFI_type_int,
sizeof (int), 2, NULL));
check_CFI_status ("CFI_select_part",
CFI_select_part (iarray, a, offsetof (struct m, i),
sizeof (int)));
check_CFI_status ("CFI_establish",
CFI_establish (jarray, NULL, CFI_attribute_pointer,
CFI_type_int,
sizeof (int), 2, NULL));
check_CFI_status ("CFI_select_part",
CFI_select_part (jarray, a, offsetof (struct m, j),
sizeof (int)));
/* Sanity checking to make sure the descriptor has been initialized
properly. */
dump_CFI_cdesc_t (iarray);
if (iarray->version != CFI_VERSION)
abort ();
if (iarray->rank != 2)
abort ();
if (iarray->attribute != CFI_attribute_pointer)
abort ();
if (!iarray->base_addr)
abort ();
if (iarray->dim[0].extent != a->dim[0].extent)
abort ();
if (iarray->dim[1].extent != a->dim[1].extent)
abort ();
dump_CFI_cdesc_t (jarray);
if (jarray->version != CFI_VERSION)
abort ();
if (jarray->rank != 2)
abort ();
if (jarray->attribute != CFI_attribute_pointer)
abort ();
if (!jarray->base_addr)
abort ();
if (jarray->dim[0].extent != a->dim[0].extent)
abort ();
if (jarray->dim[1].extent != a->dim[1].extent)
abort ();
/* Call back into Fortran. */
ftest (iarray, jarray);
}

74
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-7.f90 Normal file
View file

@ -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

73
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-8-c.c Normal file
View file

@ -0,0 +1,73 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a);
extern void ftest1 (CFI_cdesc_t *a, int lb1, int lb2);
extern void ftest2 (CFI_cdesc_t *a);
struct m {
int i;
int j;
};
#define imax 10
#define jmax 5
void
ctest (CFI_cdesc_t *a)
{
CFI_CDESC_T(2) bdesc;
CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
int i, j;
CFI_index_t subscripts[2];
struct m* mp;
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
if (a->rank != 2)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
/* Fill in bdesc. */
subscripts[0] = a->dim[0].extent;
subscripts[1] = a->dim[1].extent;
check_CFI_status ("CFI_establish",
CFI_establish (b, NULL, CFI_attribute_pointer,
CFI_type_struct,
sizeof (struct m), 2, subscripts));
/* Pass the unassociated pointer descriptor b back to Fortran for
checking. */
dump_CFI_cdesc_t (b);
ftest2 (b);
/* Point the descriptor b at the input argument array, and check that
on the Fortran side. */
subscripts[0] = a->dim[0].lower_bound;
subscripts[1] = a->dim[1].lower_bound;
check_CFI_status ("CFI_setpointer",
CFI_setpointer (b, a, subscripts));
dump_CFI_cdesc_t (b);
ftest1 (b, (int)subscripts[0], (int)subscripts[1]);
/* Diddle the lower bounds and try again. */
subscripts[0] = 42;
subscripts[1] = -69;
check_CFI_status ("CFI_setpointer",
CFI_setpointer (b, b, subscripts));
dump_CFI_cdesc_t (b);
ftest1 (b, 42, -69);
/* Disassociate the pointer and check that. */
check_CFI_status ("CFI_setpointer",
CFI_setpointer (b, NULL, NULL));
dump_CFI_cdesc_t (b);
ftest2 (b);
}

78
gcc/testsuite/gfortran.dg/c-interop/cf-descriptor-8.f90 Normal file
View file

@ -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

87
gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-1-c.c Normal file
View file

@ -0,0 +1,87 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a, CFI_cdesc_t *b);
extern void ftest2 (CFI_cdesc_t *a, CFI_cdesc_t *b);
struct m {
int i;
int j;
};
#define imax 10
#define jmax 5
void
ctest (CFI_cdesc_t *a, CFI_cdesc_t *b)
{
CFI_index_t i, j;
CFI_index_t s[2];
struct m *mpa, *mpb;
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
if (a->rank != 2)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
if (a->dim[0].lower_bound != 0)
abort ();
if (a->dim[0].extent != imax)
abort ();
if (a->dim[1].lower_bound != 0)
abort ();
if (a->dim[1].extent != jmax)
abort ();
dump_CFI_cdesc_t (b);
if (b->rank != 2)
abort ();
if (b->attribute != CFI_attribute_other)
abort ();
if (b->dim[0].lower_bound != 0)
abort ();
if (b->dim[0].extent != jmax)
abort ();
if (b->dim[1].lower_bound != 0)
abort ();
if (b->dim[1].extent != imax)
abort ();
/* Call back into Fortran, passing both the a and b arrays. */
ftest2 (a, b);
/* Check that we got a valid b array back. */
dump_CFI_cdesc_t (b);
if (b->rank != 2)
abort ();
if (b->attribute != CFI_attribute_other)
abort ();
if (b->dim[0].lower_bound != 0)
abort ();
if (b->dim[0].extent != jmax)
abort ();
if (b->dim[1].lower_bound != 0)
abort ();
if (b->dim[1].extent != imax)
abort ();
for (j = 0; j < jmax; j++)
for (i = 0; i < imax; i++)
{
s[0] = i;
s[1] = j;
mpa = (struct m *) CFI_address (a, s);
s[0] = j;
s[1] = i;
mpb = (struct m *) CFI_address (b, s);
if (mpa->i != mpb->i)
abort ();
if (mpa->j != mpb->j)
abort ();
}
}

174
gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-1.f90 Normal file
View file

@ -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

87
gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-2-c.c Normal file
View file

@ -0,0 +1,87 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a, CFI_cdesc_t *b);
extern void ftest2 (CFI_cdesc_t *a, CFI_cdesc_t *b);
struct m {
int i;
int j;
};
#define imax 10
#define jmax 5
void
ctest (CFI_cdesc_t *a, CFI_cdesc_t *b)
{
CFI_index_t i, j;
CFI_index_t s[2];
struct m *mpa, *mpb;
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
if (a->rank != 2)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
if (a->dim[0].lower_bound != 0)
abort ();
if (a->dim[0].extent != imax)
abort ();
if (a->dim[1].lower_bound != 0)
abort ();
if (a->dim[1].extent != jmax)
abort ();
dump_CFI_cdesc_t (b);
if (b->rank != 2)
abort ();
if (b->attribute != CFI_attribute_other)
abort ();
if (b->dim[0].lower_bound != 0)
abort ();
if (b->dim[0].extent != jmax)
abort ();
if (b->dim[1].lower_bound != 0)
abort ();
if (b->dim[1].extent != imax)
abort ();
/* Call back into Fortran, passing both the a and b arrays. */
ftest2 (a, b);
/* Check that we got a valid b array back. */
dump_CFI_cdesc_t (b);
if (b->rank != 2)
abort ();
if (b->attribute != CFI_attribute_other)
abort ();
if (b->dim[0].lower_bound != 0)
abort ();
if (b->dim[0].extent != jmax)
abort ();
if (b->dim[1].lower_bound != 0)
abort ();
if (b->dim[1].extent != imax)
abort ();
for (j = 0; j < jmax; j++)
for (i = 0; i < imax; i++)
{
s[0] = i;
s[1] = j;
mpa = (struct m *) CFI_address (a, s);
s[0] = j;
s[1] = i;
mpb = (struct m *) CFI_address (b, s);
if (mpa->i != mpb->i)
abort ();
if (mpa->j != mpb->j)
abort ();
}
}

157
gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-2.f90 Normal file
View file

@ -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

108
gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3-c.c Normal file
View file

@ -0,0 +1,108 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (int imagic, int jmagic);
extern void frob (CFI_cdesc_t *a, CFI_cdesc_t *aa, CFI_cdesc_t *p);
struct m {
int i;
int j;
};
void
ctest (int imagic, int jmagic)
{
CFI_CDESC_T(0) adesc;
CFI_CDESC_T(0) aadesc;
CFI_CDESC_T(0) bdesc;
CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc;
CFI_cdesc_t *aa = (CFI_cdesc_t *) &aadesc;
CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
/* Create and sanity-check descriptors. */
check_CFI_status ("CFI_establish",
CFI_establish (a, NULL, CFI_attribute_allocatable,
CFI_type_struct,
sizeof (struct m), 0, NULL));
dump_CFI_cdesc_t (a);
if (a->version != CFI_VERSION)
abort ();
if (a->rank != 0)
abort ();
if (a->attribute != CFI_attribute_allocatable)
abort ();
if (a->base_addr)
abort ();
if (a->elem_len != sizeof (struct m))
abort ();
check_CFI_status ("CFI_establish",
CFI_establish (aa, NULL, CFI_attribute_allocatable,
CFI_type_struct,
sizeof (struct m), 0, NULL));
dump_CFI_cdesc_t (aa);
if (aa->version != CFI_VERSION)
abort ();
if (aa->rank != 0)
abort ();
if (aa->attribute != CFI_attribute_allocatable)
abort ();
if (aa->base_addr)
abort ();
if (aa->elem_len != sizeof (struct m))
abort ();
check_CFI_status ("CFI_allocate",
CFI_allocate (aa, NULL, NULL, 0));
((struct m *)aa->base_addr)->i = 0;
((struct m *)aa->base_addr)->j = 0;
check_CFI_status ("CFI_establish",
CFI_establish (b, NULL, CFI_attribute_pointer,
CFI_type_struct,
sizeof (struct m), 0, NULL));
dump_CFI_cdesc_t (b);
if (b->version != CFI_VERSION)
abort ();
if (b->rank != 0)
abort ();
if (b->attribute != CFI_attribute_pointer)
abort ();
if (b->base_addr)
abort ();
if (b->elem_len != sizeof (struct m))
abort ();
/* Call back into Fortran, which will allocate and initialize the
objects. */
frob (a, aa, b);
if (!a->base_addr)
abort ();
if (a->elem_len != sizeof (struct m))
abort ();
if (((struct m *)a->base_addr)->i != imagic)
abort ();
if (((struct m *)a->base_addr)->j != jmagic)
abort ();
if (!aa->base_addr)
abort ();
if (aa->elem_len != sizeof (struct m))
abort ();
if (((struct m *)aa->base_addr)->i != imagic)
abort ();
if (((struct m *)aa->base_addr)->j != jmagic)
abort ();
if (!b->base_addr)
abort ();
if (b->elem_len != sizeof (struct m))
abort ();
if (((struct m *)b->base_addr)->i != imagic)
abort ();
if (((struct m *)b->base_addr)->j != jmagic)
abort ();
}

134
gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-3.f90 Normal file
View file

@ -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

175
gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4-c.c Normal file
View file

@ -0,0 +1,175 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (int imax, int jmax);
extern void frob (CFI_cdesc_t *a, CFI_cdesc_t *aa, CFI_cdesc_t *p);
struct m {
int i;
int j;
};
void
ctest (int imax, int jmax)
{
CFI_CDESC_T(2) adesc;
CFI_CDESC_T(2) aadesc;
CFI_CDESC_T(2) bdesc;
CFI_cdesc_t *a = (CFI_cdesc_t *) &adesc;
CFI_cdesc_t *aa = (CFI_cdesc_t *) &aadesc;
CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
CFI_index_t i, j;
CFI_index_t s[2];
CFI_index_t lb[2], ub[2];
struct m* mp;
/* Create and sanity-check a. */
check_CFI_status ("CFI_establish",
CFI_establish (a, NULL, CFI_attribute_allocatable,
CFI_type_struct,
sizeof (struct m), 2, NULL));
dump_CFI_cdesc_t (a);
if (a->version != CFI_VERSION)
abort ();
if (a->rank != 2)
abort ();
if (a->attribute != CFI_attribute_allocatable)
abort ();
if (a->base_addr)
abort ();
if (a->elem_len != sizeof (struct m))
abort ();
check_CFI_status ("CFI_establish",
CFI_establish (aa, NULL, CFI_attribute_allocatable,
CFI_type_struct,
sizeof (struct m), 2, NULL));
dump_CFI_cdesc_t (aa);
if (aa->version != CFI_VERSION)
abort ();
if (aa->rank != 2)
abort ();
if (aa->attribute != CFI_attribute_allocatable)
abort ();
if (aa->base_addr)
abort ();
if (aa->elem_len != sizeof (struct m))
abort ();
/* aa is allocated/initialized so that we can confirm that it's
magically deallocated when passed as intent(out). */
lb[0] = 0;
lb[1] = 0;
ub[0] = jmax;
ub[1] = jmax;
check_CFI_status ("CFI_allocate",
CFI_allocate (aa, lb, ub, 0));
for (j = 1; j <= jmax; j++)
for (i = 1; i <= imax; i++)
{
s[0] = j;
s[1] = i;
mp = (struct m *)CFI_address (aa, s);
mp->i = 0;
mp->j = 0;
}
/* Likewise create and sanity-check b. */
check_CFI_status ("CFI_establish",
CFI_establish (b, NULL, CFI_attribute_pointer,
CFI_type_struct,
sizeof (struct m), 2, NULL));
dump_CFI_cdesc_t (b);
if (b->version != CFI_VERSION)
abort ();
if (b->rank != 2)
abort ();
if (b->attribute != CFI_attribute_pointer)
abort ();
if (b->base_addr)
abort ();
if (b->elem_len != sizeof (struct m))
abort ();
/* Call back into Fortran, which will allocate and initialize the
objects. */
frob (a, aa, b);
dump_CFI_cdesc_t (a);
if (!a->base_addr)
abort ();
if (a->elem_len != sizeof (struct m))
abort ();
if (a->dim[0].lower_bound != 1)
abort ();
if (a->dim[0].extent != imax)
abort ();
if (a->dim[1].lower_bound != 1)
abort ();
if (a->dim[1].extent != jmax)
abort ();
for (j = 1; j <= jmax; j++)
for (i = 1; i <= imax; i++)
{
s[0] = i;
s[1] = j;
mp = (struct m *)CFI_address (a, s);
if (mp->i != i)
abort ();
if (mp->j != j)
abort ();
}
dump_CFI_cdesc_t (aa);
if (!aa->base_addr)
abort ();
if (aa->elem_len != sizeof (struct m))
abort ();
if (aa->dim[0].lower_bound != 1)
abort ();
if (aa->dim[0].extent != imax)
abort ();
if (aa->dim[1].lower_bound != 1)
abort ();
if (aa->dim[1].extent != jmax)
abort ();
for (j = 1; j <= jmax; j++)
for (i = 1; i <= imax; i++)
{
s[0] = i;
s[1] = j;
mp = (struct m *)CFI_address (aa, s);
if (mp->i != i)
abort ();
if (mp->j != j)
abort ();
}
dump_CFI_cdesc_t (b);
if (!b->base_addr)
abort ();
if (b->elem_len != sizeof (struct m))
abort ();
if (b->dim[0].lower_bound != 1)
abort ();
if (b->dim[0].extent != jmax)
abort ();
if (b->dim[1].lower_bound != 1)
abort ();
if (b->dim[1].extent != imax)
abort ();
for (j = 1; j <= jmax; j++)
for (i = 1; i <= imax; i++)
{
s[0] = j;
s[1] = i;
mp = (struct m *)CFI_address (b, s);
if (mp->i != i)
abort ();
if (mp->j != j)
abort ();
}
}

207
gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-4.f90 Normal file
View file

@ -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

31
gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5-c.c Normal file
View file

@ -0,0 +1,31 @@
#include <stdlib.h>
#include <string.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a, int n);
extern void ftest (CFI_cdesc_t *a, int n);
void
ctest (CFI_cdesc_t *a, int n)
{
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
/* The actual argument object on the Fortran side has length n and
was passed as character(len=*).
Make sure that matches what's in the descriptor. */
if (!a->base_addr)
abort ();
if (a->elem_len != n)
abort ();
if (a->rank != 0)
abort ();
if (a->type != CFI_type_char)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
ftest (a, n);
}

48
gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-5.f90 Normal file
View file

@ -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

42
gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6-c.c Normal file
View file

@ -0,0 +1,42 @@
#include <stdlib.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a, int n);
extern void ftest (CFI_cdesc_t *a, int n);
void
ctest (CFI_cdesc_t *a, int n)
{
int i;
CFI_index_t s[1];
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
if (!a->base_addr)
abort ();
if (a->elem_len != sizeof(int))
abort ();
if (a->rank != 1)
abort ();
if (a->type != CFI_type_int)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
if (a->dim[0].lower_bound != 0)
abort ();
if (a->dim[0].extent != -1)
abort ();
ftest (a, n);
for (i = 0; i < n; i++)
{
s[0] = i;
if (*((int *)CFI_address (a, s)) != i + 1)
abort ();
}
}

115
gcc/testsuite/gfortran.dg/c-interop/cf-out-descriptor-6.f90 Normal file
View file

@ -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

56
gcc/testsuite/gfortran.dg/c-interop/contiguous-1-c.c Normal file
View file

@ -0,0 +1,56 @@
#include <stdlib.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest1 (CFI_cdesc_t *a);
extern void ctest2 (CFI_cdesc_t *a);
static void
ctest (CFI_cdesc_t *a)
{
int i;
int *p;
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
/* Make sure we got a valid descriptor. */
if (!a->base_addr)
abort ();
if (a->elem_len != sizeof(int))
abort ();
if (a->rank != 1)
abort ();
if (a->type != CFI_type_int)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
if (a->dim[0].sm != sizeof(int))
abort ();
if (!CFI_is_contiguous (a))
abort ();
/* Negate the elements of the array. */
p = (int *)a->base_addr;
for (i = 0; i < a->dim[0].extent; i++)
p[i] = -p[i];
}
/* The two entry points are declared differently on the C side, but both
should do the same thing. */
void
ctest1 (CFI_cdesc_t *a)
{
ctest (a);
}
void
ctest2 (CFI_cdesc_t *a)
{
ctest (a);
}

67
gcc/testsuite/gfortran.dg/c-interop/contiguous-1.f90 Normal file
View file

@ -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

113
gcc/testsuite/gfortran.dg/c-interop/contiguous-2-c.c Normal file
View file

@ -0,0 +1,113 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest1 (CFI_cdesc_t *a);
extern void ctest2 (CFI_cdesc_t *a);
extern void ftest1 (CFI_cdesc_t *a, int first, int last, int step);
extern void ftest2 (CFI_cdesc_t *a, int first, int last, int step);
#if 0
static void
dump_array (CFI_cdesc_t *a, const char *name, const char *note)
{
int i;
fprintf (stderr, "%s\n", note);
for (i = 0; i < a->dim[0].extent; i++)
{
int j = i + a->dim[0].lower_bound;
int elt;
CFI_index_t sub[1];
sub[0] = j;
elt = *((int *) CFI_address (a, sub));
fprintf (stderr, "%s[%d] = %d\n", name, j, elt);
}
fprintf (stderr, "\n");
}
#else
#define dump_array(a, name, note)
#endif
static void
ctest (CFI_cdesc_t *a, int lb, int ub, int s,
void (*fn) (CFI_cdesc_t *, int, int, int))
{
CFI_CDESC_T(1) bdesc;
CFI_cdesc_t *b = (CFI_cdesc_t *) &bdesc;
CFI_index_t lb_array[1], ub_array[1], s_array[1];
int i;
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
/* Make sure we got a valid descriptor. */
if (!a->base_addr)
abort ();
if (a->elem_len != sizeof(int))
abort ();
if (a->rank != 1)
abort ();
if (a->type != CFI_type_int)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
/* Create an array section and pass it to fn. */
check_CFI_status ("CFI_establish",
CFI_establish (b, NULL, CFI_attribute_other,
CFI_type_int,
sizeof (int), 1, NULL));
lb_array[0] = lb - 1 + a->dim[0].lower_bound;
ub_array[0] = ub - 1 + a->dim[0].lower_bound;
s_array[0] = s;
check_CFI_status ("CFI_section",
CFI_section (b, a, lb_array, ub_array, s_array));
dump_CFI_cdesc_t (b);
dump_array (b, "b", "b after CFI_section");
/* Pass it to the Fortran function fn. */
if (CFI_is_contiguous (b))
abort ();
(*fn) (b, lb, ub, s);
dump_CFI_cdesc_t (b);
dump_array (b, "b", "b after calling Fortran fn");
/* fn is supposed to negate the elements of the array section it
receives. Check that the original array has been updated. */
dump_array (a, "a", "a after calling Fortran fn");
for (i = 0; i < a->dim[0].extent; i++)
{
int elt;
int j = i + a->dim[0].lower_bound;
CFI_index_t sub[1];
sub[0] = j;
elt = *((int *) CFI_address (a, sub));
if (i + 1 >= lb && i + 1 <= ub && (i + 1 - lb) % s == 0)
{
if (elt != - (i + 1))
abort ();
}
else if (elt != (i + 1))
abort ();
}
}
/* Entry points for the Fortran side. */
void
ctest1 (CFI_cdesc_t *a)
{
ctest (a, 5, 13, 2, ftest1);
}
void
ctest2 (CFI_cdesc_t *a)
{
ctest (a, 8, 20, 3, ftest2);
}

152
gcc/testsuite/gfortran.dg/c-interop/contiguous-2.f90 Normal file
View file

@ -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

80
gcc/testsuite/gfortran.dg/c-interop/contiguous-3-c.c Normal file
View file

@ -0,0 +1,80 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest1 (CFI_cdesc_t *a, int first, int last, int step);
extern void ctest2 (CFI_cdesc_t *a, int first, int last, int step);
extern void ftest1 (CFI_cdesc_t *a, int first, int last, int step);
extern void ftest2 (CFI_cdesc_t *a, int first, int last, int step);
#if 0
static void
dump_array (CFI_cdesc_t *a, const char *name, const char *note)
{
int i;
fprintf (stderr, "%s\n", note);
for (i = 0; i < a->dim[0].extent; i++)
{
int j = i + a->dim[0].lower_bound;
int elt;
CFI_index_t sub[1];
sub[0] = j;
elt = *((int *) CFI_address (a, sub));
fprintf (stderr, "%s[%d] = %d\n", name, j, elt);
}
fprintf (stderr, "\n");
}
#else
#define dump_array(a, name, note)
#endif
static void
ctest (CFI_cdesc_t *a, int first, int last, int step,
void (*fn) (CFI_cdesc_t *, int, int, int))
{
int i;
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
dump_array (a, "a", "a on input to ctest");
/* Make sure we got a valid descriptor. */
if (!a->base_addr)
abort ();
if (a->elem_len != sizeof(int))
abort ();
if (a->rank != 1)
abort ();
if (a->type != CFI_type_int)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
/* Pass it to the Fortran function fn. */
(*fn) (a, first, last, step);
dump_CFI_cdesc_t (a);
dump_array (a, "a", "a after calling Fortran fn");
}
/* Entry points for the Fortran side.
Note that the Fortran code has already created the array section
and these functions were declared without the CONTIGUOUS attribute
so they receive a non-contiguous array. The magic is supposed to
happen when we pass them back into a Fortran function declared with
the CONTIGUOUS attribute. */
void
ctest1 (CFI_cdesc_t *a, int first, int last, int step)
{
ctest (a, first, last, step, ftest1);
}
void
ctest2 (CFI_cdesc_t *a, int first, int last, int step)
{
ctest (a, first, last, step, ftest2);
}

171
gcc/testsuite/gfortran.dg/c-interop/contiguous-3.f90 Normal file
View file

@ -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

76
gcc/testsuite/gfortran.dg/c-interop/deferred-character-1.f90 Normal file
View file

@ -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

55
gcc/testsuite/gfortran.dg/c-interop/deferred-character-2.f90 Normal file
View file

@ -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

195
gcc/testsuite/gfortran.dg/c-interop/dump-descriptors.c Normal file
View file

@ -0,0 +1,195 @@
/* This file contains some useful routines for debugging problems with C
descriptors. Compiling it also acts as a test that the implementation of
ISO_Fortran_binding.h provides all the types and constants specified in
TS29113. */
#include <stdio.h>
#include <stddef.h>
#include <stdlib.h>
#include "dump-descriptors.h"
void
dump_CFI_cdesc_t (CFI_cdesc_t *d)
{
fprintf (stderr, "<CFI_cdesc_t base_addr=%p elem_len=%ld version=%d",
d->base_addr, (long)(d->elem_len), d->version);
fprintf (stderr, "\n rank=");
dump_CFI_rank_t (d->rank);
fprintf (stderr, " type=");
dump_CFI_type_t (d->type);
fprintf (stderr, " attribute=");
dump_CFI_attribute_t (d->attribute);
/* Dimension info may not be initialized if it's an allocatable
or pointer descriptor with a null base_addr. */
if (d->rank > 0 && d->base_addr)
{
CFI_rank_t i;
for (i = 0; i < d->rank; i++)
{
if (i == 0)
fprintf (stderr, "\n dim=[");
else
fprintf (stderr, ",\n ");
dump_CFI_dim_t (d->dim + i);
}
fprintf (stderr, "]");
}
fprintf (stderr, ">\n");
}
void
dump_CFI_dim_t (CFI_dim_t *d)
{
fprintf (stderr, "<CFI_dim_t lower_bound=");
dump_CFI_index_t (d->lower_bound);
fprintf (stderr, " extent=");
dump_CFI_index_t (d->extent);
fprintf (stderr, " sm=");
dump_CFI_index_t (d->sm);
fprintf (stderr, ">");
}
void
dump_CFI_attribute_t (CFI_attribute_t a)
{
switch (a)
{
case CFI_attribute_pointer:
fprintf (stderr, "CFI_attribute_pointer");
break;
case CFI_attribute_allocatable:
fprintf (stderr, "CFI_attribute_allocatable");
break;
case CFI_attribute_other:
fprintf (stderr, "CFI_attribute_other");
break;
default:
fprintf (stderr, "unknown(%d)", (int)a);
break;
}
}
void
dump_CFI_index_t (CFI_index_t i)
{
fprintf (stderr, "%ld", (long)i);
}
void
dump_CFI_rank_t (CFI_rank_t r)
{
fprintf (stderr, "%d", (int)r);
}
/* We can't use a switch statement to dispatch CFI_type_t because
the type name macros may not be unique. Iterate over a table
instead. */
struct type_name_map {
CFI_type_t t;
const char *n;
};
struct type_name_map type_names[] =
{
{ CFI_type_signed_char, "CFI_type_signed_char" },
{ CFI_type_short, "CFI_type_short" },
{ CFI_type_int, "CFI_type_int" },
{ CFI_type_long, "CFI_type_long" },
{ CFI_type_long_long, "CFI_type_long_long" },
{ CFI_type_size_t, "CFI_type_size_t" },
{ CFI_type_int8_t, "CFI_type_int8_t" },
{ CFI_type_int16_t, "CFI_type_int16_t" },
{ CFI_type_int32_t, "CFI_type_int32_t" },
{ CFI_type_int64_t, "CFI_type_int64_t" },
{ CFI_type_int_least8_t, "CFI_type_int_least8_t" },
{ CFI_type_int_least16_t, "CFI_type_int_least16_t" },
{ CFI_type_int_least32_t, "CFI_type_int_least32_t" },
{ CFI_type_int_least64_t, "CFI_type_int_least64_t" },
{ CFI_type_int_fast8_t, "CFI_type_int_fast8_t" },
{ CFI_type_int_fast16_t, "CFI_type_int_fast16_t" },
{ CFI_type_int_fast32_t, "CFI_type_int_fast32_t" },
{ CFI_type_int_fast64_t, "CFI_type_int_fast64_t" },
{ CFI_type_intmax_t, "CFI_type_intmax_t" },
{ CFI_type_intptr_t, "CFI_type_intptr_t" },
{ CFI_type_ptrdiff_t, "CFI_type_ptrdiff_t" },
{ CFI_type_float, "CFI_type_float" },
{ CFI_type_double, "CFI_type_double" },
{ CFI_type_long_double, "CFI_type_long_double" },
{ CFI_type_float_Complex, "CFI_type_float_Complex" },
{ CFI_type_double_Complex, "CFI_type_double_Complex" },
{ CFI_type_long_double_Complex, "CFI_type_long_double_Complex" },
{ CFI_type_Bool, "CFI_type_Bool" },
{ CFI_type_char, "CFI_type_char" },
{ CFI_type_cptr, "CFI_type_cptr" },
{ CFI_type_struct, "CFI_type_struct" },
{ CFI_type_other, "CFI_type_other" },
/* Extension types */
{ CFI_type_int128_t, "CFI_type_int128_t" },
{ CFI_type_int_least128_t, "CFI_type_int_least128_t" },
{ CFI_type_int_fast128_t, "CFI_type_int_fast128_t" },
{ CFI_type_ucs4_char, "CFI_type_ucs4_char" },
{ CFI_type_float128, "CFI_type_float128" },
{ CFI_type_float128_Complex, "CFI_type_float128_Complex" },
{ CFI_type_cfunptr, "CFI_type_cfunptr" }
};
void
dump_CFI_type_t (CFI_type_t t)
{
int i;
for (i = 0; i < sizeof (type_names) / sizeof (struct type_name_map); i++)
if (type_names[i].t == t)
{
fprintf (stderr, "%s", type_names[i].n);
return;
}
fprintf (stderr, "unknown(%d)", (int)t);
}
void
check_CFI_status (const char *fn, int code)
{
const char *msg;
switch (code)
{
case CFI_SUCCESS:
return;
case CFI_ERROR_BASE_ADDR_NULL:
msg = "CFI_ERROR_BASE_ADDR_NULL";
break;
case CFI_ERROR_BASE_ADDR_NOT_NULL:
msg = "CFI_ERROR_BASE_ADDR_NOT_NULL";
break;
case CFI_INVALID_ELEM_LEN:
msg = "CFI_INVALID_ELEM_LEN";
break;
case CFI_INVALID_RANK:
msg = "CFI_INVALID_RANK";
break;
case CFI_INVALID_TYPE:
msg = "CFI_INVALID_TYPE";
break;
case CFI_INVALID_ATTRIBUTE:
msg = "CFI_INVALID_ATTRIBUTE";
break;
case CFI_INVALID_EXTENT:
msg = "CFI_INVALID_EXTENT";
break;
case CFI_INVALID_DESCRIPTOR:
msg = "CFI_INVALID_DESCRIPTOR";
break;
case CFI_ERROR_MEM_ALLOCATION:
msg = "CFI_ERROR_MEM_ALLOCATION";
break;
case CFI_ERROR_OUT_OF_BOUNDS:
msg = "CFI_ERROR_OUT_OF_BOUNDS";
break;
default:
msg = "unknown error";
break;
}
fprintf (stderr, "%s returned %s\n", fn, msg);
abort ();
}

12
gcc/testsuite/gfortran.dg/c-interop/dump-descriptors.h Normal file
View file

@ -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);

134
gcc/testsuite/gfortran.dg/c-interop/establish-c.c Normal file
View file

@ -0,0 +1,134 @@
#include <stdlib.h>
#include <stdint.h>
#include <stdio.h>
#include <string.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
/* For simplicity, point descriptors at a static buffer. BUFSIZE should
be large enough for any of the standard types and we'll use DIM0 and DIM1
for array dimensions. */
#define BUFSIZE 64
#define DIM0 3
#define DIM1 10
#define ARRAYBUFSIZE BUFSIZE * DIM0 * DIM1
static char *buf[ARRAYBUFSIZE] __attribute__ ((aligned (8)));
static CFI_index_t extents[] = {DIM0, DIM1};
/* Magic number to use for elem_len field. */
#define MAGIC_ELEM_LEN 20
struct tc_info
{
CFI_type_t typecode;
char *name;
size_t size;
};
static struct tc_info tc_table[] =
{
{ CFI_type_signed_char, "CFI_type_signed_char", sizeof (signed char) },
{ CFI_type_short, "CFI_type_short", sizeof (short) },
{ CFI_type_int, "CFI_type_int", sizeof (int) },
{ CFI_type_long, "CFI_type_long", sizeof (long) },
{ CFI_type_long_long, "CFI_type_long_long", sizeof (long long) },
{ CFI_type_size_t, "CFI_type_size_t", sizeof (size_t) },
{ CFI_type_int8_t, "CFI_type_int8_t", sizeof (int8_t) },
{ CFI_type_int16_t, "CFI_type_int16_t", sizeof (int16_t) },
{ CFI_type_int32_t, "CFI_type_int32_t", sizeof (int32_t) },
{ CFI_type_int64_t, "CFI_type_int64_t", sizeof (int64_t) },
{ CFI_type_int_least8_t, "CFI_type_int_least8_t", sizeof (int_least8_t) },
{ CFI_type_int_least16_t, "CFI_type_int_least16_t", sizeof (int_least16_t) },
{ CFI_type_int_least32_t, "CFI_type_int_least32_t", sizeof (int_least32_t) },
{ CFI_type_int_least64_t, "CFI_type_int_least64_t", sizeof (int_least64_t) },
{ CFI_type_int_fast8_t, "CFI_type_int_fast8_t", sizeof (int_fast8_t) },
{ CFI_type_int_fast16_t, "CFI_type_int_fast16_t", sizeof (int_fast16_t) },
{ CFI_type_int_fast32_t, "CFI_type_int_fast32_t", sizeof (int_fast32_t) },
{ CFI_type_int_fast64_t, "CFI_type_int_fast64_t", sizeof (int_fast64_t) },
{ CFI_type_intmax_t, "CFI_type_intmax_t", sizeof (intmax_t) },
{ CFI_type_intptr_t, "CFI_type_intptr_t", sizeof (intptr_t) },
{ CFI_type_ptrdiff_t, "CFI_type_ptrdiff_t", sizeof (ptrdiff_t) },
{ CFI_type_float, "CFI_type_float", sizeof (float) },
{ CFI_type_double, "CFI_type_double", sizeof (double) },
{ CFI_type_long_double, "CFI_type_long_double", sizeof (long double) },
{ CFI_type_float_Complex, "CFI_type_float_Complex",
sizeof (float _Complex) },
{ CFI_type_double_Complex, "CFI_type_double_Complex",
sizeof (double _Complex) },
{ CFI_type_long_double_Complex, "CFI_type_long_double_Complex",
sizeof (long double _Complex) },
{ CFI_type_Bool, "CFI_type_Bool", sizeof (_Bool) },
{ CFI_type_char, "CFI_type_char", sizeof (char) },
{ CFI_type_cptr, "CFI_type_cptr", sizeof (void *) },
{ CFI_type_struct, "CFI_type_struct", 0 },
{ CFI_type_other, "CFI_type_other", -1 }
};
int
test_array (struct tc_info *tc, void *ptr, CFI_attribute_t attr)
{
CFI_CDESC_T(2) desc;
CFI_cdesc_t *a = (CFI_cdesc_t *) &desc;
int bad = 0;
size_t elem_len;
/* Initialize the descriptor to garbage values so we can confirm it's
properly initialized with good ones later. */
memset (a, -1, sizeof(desc));
check_CFI_status ("CFI_establish",
CFI_establish (a, ptr, attr, tc->typecode,
MAGIC_ELEM_LEN, 2, extents));
/* elem_len is ignored unless type is CFI type struct, CFI type other,
or a character type. */
if (tc->typecode == CFI_type_char
|| tc->typecode == CFI_type_struct
|| tc->typecode == CFI_type_other)
elem_len = MAGIC_ELEM_LEN;
else
elem_len = tc->size;
if (a->elem_len != elem_len
|| a->base_addr != ptr
|| a->type != tc->typecode
|| a->version != CFI_VERSION
|| a->attribute != attr
|| a->rank != 2
|| (ptr &&
/* extents parameter is ignored if ptr is null */
(a->dim[0].lower_bound != 0
|| a->dim[0].extent != DIM0
|| a->dim[0].sm != elem_len
|| a->dim[1].lower_bound != 0
|| a->dim[1].extent != DIM1
|| a->dim[1].sm != elem_len*DIM0)))
{
fprintf (stderr, "Bad array descriptor for %s:\n", tc->name);
dump_CFI_cdesc_t (a);
return 1;
}
return 0;
}
/* External entry point. */
extern void ctest_establish (void);
void
ctest_establish (void)
{
int ncodes = sizeof (tc_table) / sizeof (struct tc_info);
int i;
int bad = 0;
for (i = 0; i < ncodes; i++)
{
bad += test_array (&tc_table[i], (void *)buf, CFI_attribute_other);
bad += test_array (&tc_table[i], NULL, CFI_attribute_allocatable);
bad += test_array (&tc_table[i], (void *)buf, CFI_attribute_pointer);
}
if (bad)
abort ();
}

120
gcc/testsuite/gfortran.dg/c-interop/establish-errors-c.c Normal file
View file

@ -0,0 +1,120 @@
#include <stdlib.h>
#include <stdint.h>
#include <stdio.h>
#include <string.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
/* For simplicity, point descriptors at a static buffer. BUFSIZE should
be large enough for any of the standard types and we'll use DIM0 and DIM1
for array dimensions. */
#define BUFSIZE 64
#define DIM0 3
#define DIM1 10
#define ARRAYBUFSIZE BUFSIZE * DIM0 * DIM1
static char *buf[ARRAYBUFSIZE] __attribute__ ((aligned (8)));
static CFI_index_t extents[] = {DIM0, DIM1};
/* Magic number to use for elem_len field. */
#define MAGIC_ELEM_LEN 20
/* External entry point. */
extern void ctest (void);
void
ctest (void)
{
int bad = 0;
int status;
CFI_CDESC_T(2) desc;
CFI_cdesc_t *a = (CFI_cdesc_t *) &desc;
/* If the attribute argument is CFI_attribute_allocatable,
base_addr shall be a null pointer. */
status = CFI_establish (a, (void *)buf, CFI_attribute_allocatable,
CFI_type_int, 0, 2, extents);
if (status == CFI_SUCCESS)
{
fprintf (stderr,
"no error for non-null pointer with CFI_attribute_allocatable\n");
bad ++;
}
/* type shall have the value of one of the type codes in Table 18.4,
or have a positive value corresponding to an interoperable C type. */
status = CFI_establish (a, (void *)buf, CFI_attribute_other,
CFI_type_other - 1, 0, 2, extents);
if (status == CFI_SUCCESS)
{
fprintf (stderr,
"no error for invalid negative type code\n");
bad ++;
}
/* If the type is CFI_type_struct, CFI_type_other, or a Fortran
character type, elem_len shall be greater than zero and equal to
the storage size in bytes of an element of the object. */
status = CFI_establish (a, (void *)buf, CFI_attribute_other,
CFI_type_struct, 0, 2, extents);
if (status == CFI_SUCCESS)
{
fprintf (stderr,
"no error for invalid size with CFI_type_struct\n");
bad ++;
}
status = CFI_establish (a, (void *)buf, CFI_attribute_other,
CFI_type_char, 0, 2, extents);
if (status == CFI_SUCCESS)
{
fprintf (stderr,
"no error for invalid size with CFI_type_char\n");
bad ++;
}
/* Rank shall be between 0 and CFI_MAX_RANK inclusive. */
status = CFI_establish (a, NULL, CFI_attribute_allocatable,
CFI_type_int, 0, -1, extents);
if (status == CFI_SUCCESS)
{
fprintf (stderr,
"no error for negative rank\n");
bad ++;
}
status = CFI_establish (a, NULL, CFI_attribute_allocatable,
CFI_type_int, 0, CFI_MAX_RANK + 1, extents);
if (status == CFI_SUCCESS)
{
fprintf (stderr,
"no error for rank > CFI_MAX_RANK\n");
bad ++;
}
/* extents is ignored if the rank r is zero or if base_addr is a
null pointer. Otherwise, it shall be the address of an array... */
status = CFI_establish (a, (void *)buf, CFI_attribute_other,
CFI_type_int, 0, 2, NULL);
if (status == CFI_SUCCESS)
{
fprintf (stderr,
"no error for null extents\n");
bad ++;
}
/* Extents shall all be nonnegative. */
extents[1] = -extents[1];
status = CFI_establish (a, (void *)buf, CFI_attribute_other,
CFI_type_int, 0, 2, extents);
if (status == CFI_SUCCESS)
{
fprintf (stderr,
"no error for negative extents\n");
bad ++;
}
if (bad)
abort ();
}

30
gcc/testsuite/gfortran.dg/c-interop/establish-errors.f90 Normal file
View file

@ -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

35
gcc/testsuite/gfortran.dg/c-interop/establish.f90 Normal file
View file

@ -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

60
gcc/testsuite/gfortran.dg/c-interop/explicit-interface.f90 Normal file
View file

@ -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

46
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-1-c.c Normal file
View file

@ -0,0 +1,46 @@
#include <stdlib.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a);
void
ctest (CFI_cdesc_t *a)
{
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
/* The actual argument on the Fortran side was declared as
integer(C_INT) :: aa(10,-1:3)
Make sure that matches what's in the descriptor. Note that per
section 18.5.3 in the 2018 standard, for a nonallocatable nonpointer
array, the array dimensions in the descriptor reflect the shape of
the array rather than the actual bounds; the lower_bound is required
to be zero. */
if (!a->base_addr)
abort ();
if (a->elem_len != sizeof(int))
abort ();
if (a->rank != 2)
abort ();
if (a->type != CFI_type_int)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
if (a->dim[0].lower_bound != 0)
abort ();
if (a->dim[0].extent != 10)
abort ();
if (a->dim[0].sm != sizeof(int))
abort ();
if (a->dim[1].lower_bound != 0)
abort ();
if (a->dim[1].extent != 5)
abort ();
if (a->dim[1].sm != a->dim[0].extent * sizeof(int))
abort ();
if (!CFI_is_contiguous (a))
abort ();
}

34
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-1.f90 Normal file
View file

@ -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

68
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-2-c.c Normal file
View file

@ -0,0 +1,68 @@
#include <stdlib.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a, int n);
void
ctest (CFI_cdesc_t *a, int n)
{
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
if (!a->base_addr)
abort ();
if (a->elem_len != sizeof(float))
abort ();
if (a->type != CFI_type_float)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
if (n == 1)
{
/* The actual argument on the Fortran side was declared as
real(C_FLOAT):: aa(100) */
if (a->rank != 1)
abort ();
if (a->dim[0].lower_bound != 0)
abort ();
if (a->dim[0].extent != 100)
abort ();
if (a->dim[0].sm != sizeof(float))
abort ();
if (!CFI_is_contiguous (a))
abort ();
}
else if (n == 3)
{
/* The actual argument on the Fortran side was declared as
real(C_FLOAT) :: bb(3,4,5) */
if (a->rank != 3)
abort ();
if (a->dim[0].lower_bound != 0)
abort ();
if (a->dim[0].extent != 3)
abort ();
if (a->dim[0].sm != sizeof(float))
abort ();
if (a->dim[1].lower_bound != 0)
abort ();
if (a->dim[1].extent != 4)
abort ();
if (a->dim[1].sm != a->dim[0].sm * a->dim[0].extent)
abort ();
if (a->dim[2].lower_bound != 0)
abort ();
if (a->dim[2].extent != 5)
abort ();
if (a->dim[2].sm != a->dim[1].sm * a->dim[1].extent)
abort ();
if (!CFI_is_contiguous (a))
abort ();
}
else
abort ();
}

40
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-2.f90 Normal file
View file

@ -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

42
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3-c.c Normal file
View file

@ -0,0 +1,42 @@
#include <stdlib.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp);
void
ctest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp)
{
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
dump_CFI_cdesc_t (b);
/* Make sure the descriptors match what we are expecting. a is an
allocatable derived type object, b is a pointer which points at a
if initp is true. */
if (initp && !a->base_addr)
abort ();
else if (!initp && a->base_addr)
abort ();
if (a->base_addr != b->base_addr)
abort ();
if (a->rank != 0)
abort ();
if (b->rank != 0)
abort ();
if (a->type != CFI_type_struct)
abort ();
if (b->type != CFI_type_struct)
abort ();
if (a->elem_len != 3 * 3 * sizeof(double))
abort ();
if (b->elem_len != 3 * 3 * sizeof(double))
abort ();
if (a->attribute != CFI_attribute_allocatable)
abort ();
if (b->attribute != CFI_attribute_pointer)
abort ();
}

37
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-3.f90 Normal file
View file

@ -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

57
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-4-c.c Normal file
View file

@ -0,0 +1,57 @@
#include <stdlib.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp);
void
ctest (CFI_cdesc_t *a, CFI_cdesc_t *b, int initp)
{
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
dump_CFI_cdesc_t (b);
/* Make sure the descriptors match what we are expecting. a is an
allocatable derived type object, b is a pointer which points at a
if initp is true. */
if (initp && !a->base_addr)
abort ();
else if (!initp && a->base_addr)
abort ();
if (a->base_addr != b->base_addr)
abort ();
if (a->type != CFI_type_struct)
abort ();
if (b->type != CFI_type_struct)
abort ();
if (a->elem_len != 3 * 3 * sizeof(double))
abort ();
if (b->elem_len != 3 * 3 * sizeof(double))
abort ();
if (a->attribute != CFI_attribute_allocatable)
abort ();
if (b->attribute != CFI_attribute_pointer)
abort ();
if (initp)
/* The actual array is allocated with
allocate (aa(3:7))
Per 8.3.3 of TS29113, the lower_bound must reflect that. */
{
if (a->rank != 1)
abort ();
if (b->rank != 1)
abort ();
if (a->dim[0].lower_bound != 3)
abort ();
if (b->dim[0].lower_bound != 3)
abort ();
if (a->dim[0].extent != 5)
abort ();
if (b->dim[0].extent != 5)
abort ();
}
}

36
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-4.f90 Normal file
View file

@ -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

28
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5-c.c Normal file
View file

@ -0,0 +1,28 @@
#include <stdlib.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a);
void
ctest (CFI_cdesc_t *a)
{
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
/* The actual argument on the Fortran side was declared as
character(len=20) :: aa
Make sure that matches what's in the descriptor. */
if (!a->base_addr)
abort ();
if (a->elem_len != 20)
abort ();
if (a->rank != 0)
abort ();
if (a->type != CFI_type_char)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
}

35
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-5.f90 Normal file
View file

@ -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

51
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6-c.c Normal file
View file

@ -0,0 +1,51 @@
#include <stdlib.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a);
void
ctest (CFI_cdesc_t *a)
{
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
/* The actual argument on the Fortran side was declared as
integer(C_INT) :: aa(10,5:8)
but was passed via other functions that variously describe it as
having size (10,*), (10,1:*), or (10,5:*). But, the spec says:
For a C descriptor of a nonallocatable nonpointer object, the
value of the lower_bound member of each element of the dim member
of the descriptor is zero.
In a C descriptor of an assumed-size array, the extent member of
the last element of the dim member has the value −1. */
if (!a->base_addr)
abort ();
if (a->elem_len != sizeof(int))
abort ();
if (a->rank != 2)
abort ();
if (a->type != CFI_type_int)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
if (a->dim[0].lower_bound != 0)
abort ();
if (a->dim[0].extent != 10)
abort ();
if (a->dim[0].sm != sizeof(int))
abort ();
if (a->dim[1].lower_bound != 0)
abort ();
if (a->dim[1].extent != -1)
abort ();
if (a->dim[1].sm != a->dim[0].extent * sizeof(int))
abort ();
}

50
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-6.f90 Normal file
View file

@ -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

46
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7-c.c Normal file
View file

@ -0,0 +1,46 @@
#include <stdlib.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a);
void
ctest (CFI_cdesc_t *a)
{
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
/* We expect to get an array of shape (5,10) that may not be
contiguous. */
if (!a->base_addr)
abort ();
if (a->elem_len != sizeof(int))
abort ();
if (a->rank != 2)
abort ();
if (a->type != CFI_type_int)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
if (a->dim[0].lower_bound != 0)
abort ();
if (a->dim[0].extent != 5)
abort ();
if (a->dim[1].lower_bound != 0)
abort ();
if (a->dim[1].extent != 10)
abort ();
/* There shall be an ordering of the dimensions such that the absolute
value of the sm member of the first dimension is not less than the
elem_len member of the C descriptor and the absolute value of the sm
member of each subsequent dimension is not less than the absolute
value of the sm member of the previous dimension multiplied
by the extent of the previous dimension. */
if (abs (a->dim[0].sm) < a->elem_len)
abort ();
if (abs (a->dim[1].sm) < abs (a->dim[0].sm) * a->dim[0].extent)
abort ();
}

37
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-7.f90 Normal file
View file

@ -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

20
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-8-c.c Normal file
View file

@ -0,0 +1,20 @@
/* TS29113 8.3.1: ISO_Fortran_binding.h may be included more than once. */
#include <stdlib.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
#include <ISO_Fortran_binding.h>
extern void ctest (CFI_cdesc_t *a);
void
ctest (CFI_cdesc_t *a)
{
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
if (a->version != CFI_VERSION)
abort ();
}

22
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-8.f90 Normal file
View file

@ -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

42
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-9-c.c Normal file
View file

@ -0,0 +1,42 @@
/* 8.3.1: ISO_Fortran_binding.h may be included more than once. */
#include <stdlib.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (CFI_cdesc_t *a);
struct descriptor_fixed_part {
void *base_addr;
size_t elem_len;
int version;
};
void
ctest (CFI_cdesc_t *a)
{
struct descriptor_fixed_part *f = (struct descriptor_fixed_part *) a;
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
/* The first three members of the structure shall be base_addr,
elem_len, and version in that order. */
if (&(a->base_addr) != &(f->base_addr))
abort ();
if (&(a->elem_len) != &(f->elem_len))
abort ();
if (&(a->version) != &(f->version))
abort ();
/* The final member shall be dim, with the other members after version
and before dim in any order. */
if ((void *)&(a->rank) >= (void *)a->dim)
abort ();
if ((void *)&(a->type) >= (void *)a->dim)
abort ();
if ((void *)&(a->attribute) >= (void *)a->dim)
abort ();
}

23
gcc/testsuite/gfortran.dg/c-interop/fc-descriptor-9.f90 Normal file
View file

@ -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

52
gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-1-c.c Normal file
View file

@ -0,0 +1,52 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (int imax, int jmax, CFI_cdesc_t *a);
struct m {
int i;
int j;
};
void
ctest (int imax, int jmax, CFI_cdesc_t *a)
{
int i, j;
CFI_index_t subscripts[2];
struct m* mp;
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
if (a->rank != 2)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
if (a->dim[0].lower_bound != 0)
abort ();
if (a->dim[0].extent != imax)
abort ();
if (a->dim[1].lower_bound != 0)
abort ();
if (a->dim[1].extent != jmax)
abort ();
/* Fill in the contents of a. a is zero-based but we want the ->i and ->j
members of each element to be numbered starting from 1. */
for (j = 0; j < jmax; j++)
{
subscripts[1] = j;
for (i = 0; i < imax; i++)
{
subscripts[0] = i;
mp = (struct m *) CFI_address (a, subscripts);
mp->i = i + 1;
mp->j = j + 1;
}
}
}

66
gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-1.f90 Normal file
View file

@ -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

52
gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-2-c.c Normal file
View file

@ -0,0 +1,52 @@
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#include "dump-descriptors.h"
extern void ctest (int imax, int jmax, CFI_cdesc_t *a);
struct m {
int i;
int j;
};
void
ctest (int imax, int jmax, CFI_cdesc_t *a)
{
int i, j;
CFI_index_t subscripts[2];
struct m* mp;
/* Dump the descriptor contents to test that we can access the fields
correctly, etc. */
dump_CFI_cdesc_t (a);
if (a->rank != 2)
abort ();
if (a->attribute != CFI_attribute_other)
abort ();
if (a->dim[0].lower_bound != 0)
abort ();
if (a->dim[0].extent != imax)
abort ();
if (a->dim[1].lower_bound != 0)
abort ();
if (a->dim[1].extent != jmax)
abort ();
/* Fill in the contents of a. a is zero-based but we want the ->i and ->j
members of each element to be numbered starting from 1. */
for (j = 0; j < jmax; j++)
{
subscripts[1] = j;
for (i = 0; i < imax; i++)
{
subscripts[0] = i;
mp = (struct m *) CFI_address (a, subscripts);
mp->i = i + 1;
mp->j = j + 1;
}
}
}

Some files were not shown because too many files have changed in this diff Show more