This is an archive of the discontinued LLVM Phabricator instance.

Differential D146479

Add tests from gfortran test suite [Patch 4 of 6]
AbandonedPublic

Authored by tarunprabhu on Mar 20 2023, 5:27 PM.

Details

Reviewers
jdoerfert
kiranchandramohan
sscalpone
klausler
PeteSteinfeld
awarzynski
AlexisPerry
Summary

Add Fortran tests from GCC's test suite. This is the fourth of six patches that add the test files. A separate patch adds the build files.

  1. https://reviews.llvm.org/D146475
  2. https://reviews.llvm.org/D146477
  3. https://reviews.llvm.org/D146478
  4. https://reviews.llvm.org/D146479 (this patch)
  5. https://reviews.llvm.org/D146480
  6. https://reviews.llvm.org/D146481

A discourse post discussing this is here:

Diff Detail

Event Timeline

tarunprabhu created this revision.Mar 20 2023, 5:27 PM
tarunprabhu created this object with visibility "No One".
Herald added a project: Restricted Project. · View Herald TranscriptMar 20 2023, 5:27 PM
tarunprabhu requested review of this revision.Mar 20 2023, 5:27 PM
tarunprabhu edited the summary of this revision. (Show Details)
tarunprabhu mentioned this in D146480: Add tests from gfortran test suite [Patch 5 of 6].Mar 20 2023, 5:29 PM
tarunprabhu mentioned this in D146481: Add tests from gfortran test suite [Patch 6 of 6].Mar 20 2023, 5:33 PM
tarunprabhu edited the summary of this revision. (Show Details)
tarunprabhu mentioned this in D146478: Add tests from gfortran test suite [Patch 3 of 6].
tarunprabhu mentioned this in D146477: Add tests from gfortran test suite [Patch 2 of 6].Mar 20 2023, 5:35 PM
tarunprabhu mentioned this in D146475: Add tests from gfortran test-suite [Patch 1 of 6].
tarunprabhu edited the summary of this revision. (Show Details)Mar 20 2023, 6:23 PM
tarunprabhu set the repository for this revision to rT test-suite.
tarunprabhu changed the visibility from "No One" to "Public (No Login Required)".
tarunprabhu added a subscriber: flang-commits.
Herald added a reviewer: jdoerfert. · View Herald TranscriptMar 20 2023, 6:23 PM
Herald added subscribers: jplehr, sstefan1. · View Herald Transcript
tarunprabhu edited the summary of this revision. (Show Details)Mar 20 2023, 6:31 PM
tarunprabhu mentioned this in D146485: Add tests from gfortran test suite [build files].
tarunprabhu added reviewers: kiranchandramohan, sscalpone, klausler, PeteSteinfeld, awarzynski, AlexisPerry.Mar 20 2023, 6:39 PM
tarunprabhu abandoned this revision.Mar 31 2023, 8:03 AM

Based on discussions here, the test files will be committed after the patch containing the build and license files.

Revision Contents

PathSize
Fortran/
gfortran/
regression/
232 lines
246 lines
73 lines
99 lines
78 lines
81 lines
29 lines
53 lines
12 lines
39 lines
41 lines
43 lines
20 lines
40 lines
25 lines
25 lines
77 lines
27 lines
28 lines
28 lines
32 lines
32 lines
55 lines
83 lines
36 lines
23 lines
41 lines
102 lines
42 lines
37 lines
50 lines
14 lines
28 lines
22 lines
36 lines
37 lines
41 lines
45 lines
76 lines
198 lines
75 lines
39 lines
11 lines
28 lines
169 lines
1699 lines
82 lines
282 lines
225 lines
652 lines
80 lines
273 lines
9 lines
22 lines
20 lines
6 lines
15 lines
14 lines
51 lines
60 lines
47 lines
144 lines
19 lines
52 lines
197 lines
132 lines
29 lines
29 lines
103 lines
168 lines
70 lines
195 lines
73 lines
252 lines
83 lines
84 lines
163 lines
27 lines
72 lines
34 lines
49 lines
58 lines
12 lines
12 lines

Diff 506791

Fortran/gfortran/regression/ISO_Fortran_binding_1.c

/* Test F2008 18.5: ISO_Fortran_binding.h functions. */
#include <ISO_Fortran_binding.h>
#include <assert.h>
#include <stdio.h>
#include <stdlib.h>
#include <complex.h>
/* Test the example in F2008 C.12.9: Processing assumed-shape arrays in C,
modified to use CFI_address instead of pointer arithmetic. */
int elemental_mult_c(CFI_cdesc_t * a_desc, CFI_cdesc_t * b_desc,
CFI_cdesc_t * c_desc)
{
CFI_index_t idx[2];
int *res_addr;
int err = 1; /* this error code represents all errors */
if (a_desc->rank == 0)
{
err = *(int*)a_desc->base_addr;
*(int*)a_desc->base_addr = 0;
return err;
}
if (a_desc->type != CFI_type_int
|| b_desc->type != CFI_type_int
|| c_desc->type != CFI_type_int)
return err;
/* Only support two dimensions. */
if (a_desc->rank != 2
|| b_desc->rank != 2
|| c_desc->rank != 2)
return err;
if (a_desc->attribute == CFI_attribute_other)
{
assert (a_desc->dim[0].lower_bound == 0);
assert (a_desc->dim[1].lower_bound == 0);
for (idx[0] = 0; idx[0] < a_desc->dim[0].extent; idx[0]++)
for (idx[1] = 0; idx[1] < a_desc->dim[1].extent; idx[1]++)
{
res_addr = CFI_address (a_desc, idx);
*res_addr = *(int*)CFI_address (b_desc, idx)
* *(int*)CFI_address (c_desc, idx);
}
}
else
{
assert (a_desc->attribute == CFI_attribute_allocatable
|| a_desc->attribute == CFI_attribute_pointer);
for (idx[0] = a_desc->dim[0].lower_bound;
idx[0] < a_desc->dim[0].extent + a_desc->dim[0].lower_bound;
idx[0]++)
for (idx[1] = a_desc->dim[1].lower_bound;
idx[1] < a_desc->dim[1].extent + a_desc->dim[1].lower_bound;
idx[1]++)
{
res_addr = CFI_address (a_desc, idx);
*res_addr = *(int*)CFI_address (b_desc, idx)
* *(int*)CFI_address (c_desc, idx);
}
}
return 0;
}
int deallocate_c(CFI_cdesc_t * dd)
{
return CFI_deallocate(dd);
}
int allocate_c(CFI_cdesc_t * da, CFI_index_t lower[], CFI_index_t upper[])
{
int err = 1;
CFI_index_t idx[2];
int *res_addr;
if (da->attribute == CFI_attribute_other) return err;
if (CFI_allocate(da, lower, upper, 0)) return err;
assert (da->dim[0].lower_bound == lower[0]);
assert (da->dim[1].lower_bound == lower[1]);
for (idx[0] = lower[0]; idx[0] < da->dim[0].extent + lower[0]; idx[0]++)
for (idx[1] = lower[1]; idx[1] < da->dim[1].extent + lower[1]; idx[1]++)
{
res_addr = CFI_address (da, idx);
*res_addr = (int)(idx[0] * idx[1]);
}
return 0;
}
int establish_c(CFI_cdesc_t * desc)
{
typedef struct {double x; double _Complex y;} t;
int err;
CFI_index_t idx[1], extent[1];
t *res_addr;
double value = 1.0;
double complex z_value = 0.0 + 2.0 * I;
extent[0] = 10;
err = CFI_establish((CFI_cdesc_t *)desc,
malloc ((size_t)(extent[0] * sizeof(t))),
CFI_attribute_pointer,
CFI_type_struct,
sizeof(t), 1, extent);
assert (desc->dim[0].lower_bound == 0);
for (idx[0] = 0; idx[0] < extent[0]; idx[0]++)
{
res_addr = (t*)CFI_address (desc, idx);
res_addr->x = value++;
res_addr->y = z_value * (idx[0] + 1);
}
return err;
}
int contiguous_c(CFI_cdesc_t * desc)
{
return CFI_is_contiguous(desc);
}
float section_c(int *std_case, CFI_cdesc_t * source, int *low, int *str)
{
CFI_index_t idx[CFI_MAX_RANK], lower[CFI_MAX_RANK],
strides[CFI_MAX_RANK], upper[CFI_MAX_RANK];
CFI_CDESC_T(1) section;
int ind;
float *ret_addr;
float ans = 0.0;
/* Case (i) from F2018:18.5.5.7. */
if (*std_case == 1)
{
lower[0] = (CFI_index_t)low[0];
strides[0] = (CFI_index_t)str[0];
ind = CFI_establish((CFI_cdesc_t *)&section, NULL, CFI_attribute_other,
CFI_type_float, 0, 1, NULL);
if (ind) return -1.0;
ind = CFI_section((CFI_cdesc_t *)&section, source, lower, NULL, strides);
if (ind) return -2.0;
/* Sum over the section */
for (idx[0] = section.dim[0].lower_bound;
idx[0] < section.dim[0].extent + section.dim[0].lower_bound;
idx[0]++)
ans += *(float*)CFI_address ((CFI_cdesc_t*)&section, idx);
return ans;
}
else if (*std_case == 2)
{
int ind;
lower[0] = source->dim[0].lower_bound;
upper[0] = source->dim[0].lower_bound + source->dim[0].extent - 1;
strides[0] = str[0];
lower[1] = upper[1] = source->dim[1].lower_bound + low[1] - 1;
strides[1] = 0;
ind = CFI_establish((CFI_cdesc_t *)&section, NULL, CFI_attribute_other,
CFI_type_float, 0, 1, NULL);
if (ind) return -1.0;
ind = CFI_section((CFI_cdesc_t *)&section, source,
lower, upper, strides);
assert (section.rank == 1);
if (ind) return -2.0;
/* Sum over the section */
for (idx[0] = section.dim[0].lower_bound;
idx[0] < section.dim[0].extent + section.dim[0].lower_bound;
idx[0]++)
ans += *(float*)CFI_address ((CFI_cdesc_t*)&section, idx);
return ans;
}
return 0.0;
}
double select_part_c (CFI_cdesc_t * source)
{
typedef struct {
double x; double _Complex y;
} t;
CFI_CDESC_T(2) component;
CFI_cdesc_t * comp_cdesc = (CFI_cdesc_t *)&component;
CFI_index_t extent[] = {10,10};
CFI_index_t idx[] = {4,0};
double ans = 0.0;
int size;
(void)CFI_establish(comp_cdesc, NULL, CFI_attribute_other,
CFI_type_double_Complex, sizeof(double _Complex),
2, extent);
(void)CFI_select_part(comp_cdesc, source, offsetof(t,y), 0);
assert (comp_cdesc->dim[0].lower_bound == 0);
assert (comp_cdesc->dim[1].lower_bound == 0);
/* Sum over comp_cdesc[4,:] */
size = comp_cdesc->dim[1].extent;
for (idx[1] = 0; idx[1] < size; idx[1]++)
ans += cimag (*(double _Complex*)CFI_address ((CFI_cdesc_t*)comp_cdesc,
idx));
return ans;
}
int setpointer_c(CFI_cdesc_t * ptr, int lbounds[])
{
CFI_index_t lower_bounds[] = {lbounds[0],lbounds[1]};
int ind;
ind = CFI_setpointer(ptr, ptr, lower_bounds);
return ind;
}
int assumed_size_c(CFI_cdesc_t * desc)
{
int res;
res = CFI_is_contiguous(desc);
if (!res)
return 1;
if (desc->rank)
res = 2 * (desc->dim[desc->rank-1].extent
!= (CFI_index_t)(long long)(-1));
else
res = 3;
return res;
}

Fortran/gfortran/regression/ISO_Fortran_binding_1.f90

! { dg-do run { target c99_runtime } }
! { dg-additional-sources ISO_Fortran_binding_1.c }
!
! Test F2008 18.5: ISO_Fortran_binding.h functions.
!
USE, INTRINSIC :: ISO_C_BINDING
TYPE, BIND(C) :: T
REAL(C_DOUBLE) :: X
complex(C_DOUBLE_COMPLEX) :: Y
END TYPE
type :: mytype
integer :: i
integer :: j
end type
INTERFACE
FUNCTION elemental_mult(a, b, c) BIND(C, NAME="elemental_mult_c") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
type(*), DIMENSION(..) :: a, b, c
END FUNCTION elemental_mult
FUNCTION c_deallocate(a) BIND(C, NAME="deallocate_c") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
INTEGER(C_INT), DIMENSION(..), allocatable :: a
END FUNCTION c_deallocate
FUNCTION c_allocate(a, lower, upper) BIND(C, NAME="allocate_c") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
INTEGER(C_INT), DIMENSION(..), allocatable :: a
integer(C_INTPTR_T), DIMENSION(15) :: lower, upper
END FUNCTION c_allocate
FUNCTION c_establish(a) BIND(C, NAME="establish_c") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
import
INTEGER(C_INT) :: err
type (T), pointer, DIMENSION(..), intent(out) :: a
END FUNCTION c_establish
FUNCTION c_contiguous(a) BIND(C, NAME="contiguous_c") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
type(*), DIMENSION(..) :: a
END FUNCTION c_contiguous
FUNCTION c_section(std_case, a, lower, strides) BIND(C, NAME="section_c") RESULT(ans)
USE, INTRINSIC :: ISO_C_BINDING
real(C_FLOAT) :: ans
INTEGER(C_INT) :: std_case
INTEGER(C_INT), dimension(15) :: lower
INTEGER(C_INT), dimension(15) :: strides
type(*), DIMENSION(..) :: a
END FUNCTION c_section
FUNCTION c_select_part(a) BIND(C, NAME="select_part_c") RESULT(ans)
USE, INTRINSIC :: ISO_C_BINDING
real(C_DOUBLE) :: ans
type(*), DIMENSION(..) :: a
END FUNCTION c_select_part
FUNCTION c_setpointer(a, lbounds) BIND(C, NAME="setpointer_c") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
INTEGER(C_INT), dimension(2) :: lbounds
INTEGER(C_INT), DIMENSION(..), pointer :: a
END FUNCTION c_setpointer
FUNCTION c_assumed_size(a) BIND(C, NAME="assumed_size_c") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
type(*), DIMENSION(..) :: a
END FUNCTION c_assumed_size
END INTERFACE
integer, dimension(:,:), allocatable :: x, y, z
integer, dimension(2,2) :: a, b, c
integer, dimension(4,4) :: d
integer :: i = 42, j, k
integer(C_INTPTR_T), dimension(15) :: lower, upper
real, dimension(10,10) :: arg
type (mytype), dimension(2,2) :: der
allocate (x, source = reshape ([4,3,2,1], [2,2]))
allocate (y, source = reshape ([2,3,4,5], [2,2]))
allocate (z, source = reshape ([0,0,0,0], [2,2]))
call test_CFI_address
call test_CFI_deallocate
call test_CFI_allocate
call test_CFI_establish
call test_CFI_contiguous (a)
call test_CFI_section (arg)
call test_CFI_select_part
call test_CFI_setpointer
call test_assumed_size (a)
contains
subroutine test_CFI_address
! Basic test that CFI_desc_t can be passed and that CFI_address works
if (elemental_mult (z, x, y) .ne. 0) stop 1
if (any (z .ne. reshape ([8,9,8,5], [2,2]))) stop 2
a = reshape ([4,3,2,1], [2,2])
b = reshape ([2,3,4,5], [2,2])
c = 0
! Verify that components of arrays of derived types are OK.
der%j = a
! Check that non-pointer/non-allocatable arguments are OK
if (elemental_mult (c, der%j, b) .ne. 0) stop 3
if (any (c .ne. reshape ([8,9,8,5], [2,2]))) stop 4
! Check array sections
d = 0
d(4:2:-2, 1:3:2) = b
if (elemental_mult (c, a, d(4:2:-2, 1:3:2)) .ne. 0) stop 5
if (any (c .ne. reshape ([8,9,8,5], [2,2]))) stop 6
! If a scalar result is passed to 'elemental_mult' it is returned
! as the function result and then zeroed. This tests that scalars
! are correctly converted to CF_desc_t.
if ((elemental_mult (i, a, b) .ne. 42) &
.or. (i .ne. 0)) stop 7
deallocate (y,z)
end subroutine test_CFI_address
subroutine test_CFI_deallocate
! Test CFI_deallocate.
if (c_deallocate (x) .ne. 0) stop 8
if (allocated (x)) stop 9
end subroutine test_CFI_deallocate
subroutine test_CFI_allocate
! Test CFI_allocate.
lower(1:2) = [2,2]
upper(1:2) = [10,10]
if (c_allocate (x, lower, upper) .ne. 0) stop 10
if (.not.allocated (x)) stop 11
if (any (lbound (x) .ne. lower(1:2))) stop 12
if (any (ubound (x) .ne. upper(1:2))) stop 13
! Elements are filled by 'c_allocate' with the product of the fortran indices
do j = lower(1) , upper(1)
do k = lower(2) , upper(2)
x(j,k) = x(j,k) - j * k
end do
end do
if (any (x .ne. 0)) stop 14
deallocate (x)
end subroutine test_CFI_allocate
subroutine test_CFI_establish
! Test CFI_establish.
type(T), pointer :: case2(:) => null()
if (c_establish(case2) .ne. 0) stop 14
if (ubound(case2, 1) .ne. 9) stop 15
if (.not.associated(case2)) stop 16
if (sizeof(case2) .ne. 240) stop 17
if (int (sum (case2%x)) .ne. 55) stop 18
if (int (sum (imag (case2%y))) .ne. 110) stop 19
deallocate (case2)
end subroutine test_CFI_establish
subroutine test_CFI_contiguous (arg)
integer, dimension (2,*) :: arg
character(4), dimension(2) :: chr
! These are contiguous
if (c_contiguous (arg) .ne. 1) stop 20
if (.not.allocated (x)) allocate (x(2, 2))
if (c_contiguous (x) .ne. 1) stop 22
deallocate (x)
if (c_contiguous (chr) .ne. 1) stop 23
! These are not contiguous
if (c_contiguous (der%i) .eq. 1) stop 24
if (c_contiguous (arg(1:1,1:2)) .eq. 1) stop 25
if (c_contiguous (d(4:2:-2, 1:3:2)) .eq. 1) stop 26
if (c_contiguous (chr(:)(2:3)) .eq. 1) stop 27
end subroutine test_CFI_contiguous
subroutine test_CFI_section (arg)
real, dimension (100) :: a
real, dimension (10,*) :: arg
integer, dimension(15) :: lower, strides
integer :: i
! Case (i) from F2018:18.5.5.7.
a = [(real(i), i = 1, 100)]
lower(1) = 10
strides(1) = 5
! Remember, 'a' being non pointer, non-allocatable, the C descriptor
! lbounds are set to zero.
if (int (sum(a(lower(1)+1::strides(1))) &
- c_section(1, a, lower, strides)) .ne. 0) stop 28
! Case (ii) from F2018:18.5.5.7.
arg(:,1:10) = reshape ([(real(i), i = 1, 100)], [10,10])
lower(1) = 1
lower(2) = 5
strides(1) = 1
strides(2) = 0
if (int (sum(arg(:,5)) &
- c_section (2, arg, lower, strides)) .ne. 0) stop 29
end subroutine test_CFI_section
subroutine test_CFI_select_part
! Test the example from F2018:18.5.5.8.
! Modify to take rank 2 and sum the section type_t(5, :)%y%im
! Note that sum_z_5 = sum (type_t(5, :)%y%im) is broken on Darwin.
!
type (t), dimension(10, 10) :: type_t
real(kind(type_t%x)) :: v, sum_z_5 = 0.0
complex(kind(type_t%y)) :: z
! Set the array 'type_t'.
do j = 1, 10
do k = 1, 10
v = dble (j * k)
z = cmplx (2 * v, 3 * v)
type_t(j, k) = t (v, z)
if (j .eq. 5) sum_z_5 = sum_z_5 + imag (z)
end do
end do
! Now do the test.
if (int (c_select_part (type_t) - sum_z_5) .ne. 0) stop 30
end subroutine test_CFI_select_part
subroutine test_CFI_setpointer
! Test the example from F2018:18.5.5.9.
integer, dimension(:,:), pointer :: ptr => NULL ()
integer, dimension(2,2), target :: tgt
integer, dimension(2) :: lbounds = [-1, -2]
! The C-function resets the lbounds
ptr(1:, 1:) => tgt
if (c_setpointer (ptr, lbounds) .ne. 0) stop 31
if (any (lbound(ptr) .ne. lbounds)) stop 32
end subroutine test_CFI_setpointer
subroutine test_assumed_size (arg)
integer, dimension(2,*) :: arg
! The C-function checks contiguousness and that extent[1] == -1.
if (c_assumed_size (arg) .ne. 0) stop 33
end subroutine
end

Fortran/gfortran/regression/ISO_Fortran_binding_10.c

/* Test the fix of PR89843. */
/* Contributed by Reinhold Bader <Bader@lrz.de> */
#include <ISO_Fortran_binding.h>
#include <stdlib.h>
#include <stdio.h>
#include <stdbool.h>
void sa(CFI_cdesc_t *, int, int *);
void si(CFI_cdesc_t *this, int flag, int *status)
{
int value, sum;
bool err;
CFI_CDESC_T(1) that;
CFI_index_t lb[] = { 0, 0 };
CFI_index_t ub[] = { 4, 0 };
CFI_index_t st[] = { 2, 0 };
int chksum[] = { 9, 36, 38 };
if (flag == 1)
{
lb[0] = 0; lb[1] = 2;
ub[0] = 2; ub[1] = 2;
st[0] = 1; st[1] = 0;
}
else if (flag == 2)
{
lb[0] = 1; lb[1] = 0;
ub[0] = 1; ub[1] = 3;
st[0] = 0; st[1] = 1;
}
CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other,
CFI_type_float, 0, 1, NULL);
*status = CFI_section((CFI_cdesc_t *) &that, this, lb, ub, st);
if (*status != CFI_SUCCESS)
{
printf("FAIL C: status is %i\n",status);
return;
}
value = CFI_is_contiguous((CFI_cdesc_t *) &that);
err = ((flag == 0 && value != 0)
|| (flag == 1 && value != 1)
|| (flag == 2 && value != 0));
if (err)
{
printf("FAIL C: contiguity for flag value %i - is %i\n", flag, value);
*status = 10;
return;
}
sum = 0;
for (int i = 0; i < that.dim[0].extent; i++)
{
CFI_index_t idx[] = {i};
sum += (int)(*(float *)CFI_address ((CFI_cdesc_t *)&that, idx));
}
if (sum != chksum[flag])
{
printf ("FAIL C: check sum = %d(%d)\n", sum, chksum[flag]);
*status = 11;
return;
}
sa((CFI_cdesc_t *) &that, flag, status);
}

Fortran/gfortran/regression/ISO_Fortran_binding_10.f90

! { dg-do run { target c99_runtime } }
! { dg-additional-sources ISO_Fortran_binding_10.c }
!
! Test the fix of PR89843.
!
! Contributed by Reinhold Bader <Bader@lrz.de>
!
module mod_section_01
use, intrinsic :: iso_c_binding
implicit none
interface
subroutine si(this, flag, status) bind(c)
import :: c_float, c_int
real(c_float) :: this(:,:)
integer(c_int), value :: flag
integer(c_int) :: status
end subroutine si
end interface
contains
subroutine sa(this, flag, status) bind(c)
real(c_float) :: this(:)
integer(c_int), value :: flag
integer(c_int) :: status
status = 0
select case (flag)
case (0)
if (is_contiguous(this)) then
write(*,*) 'FAIL 1:'
status = status + 1
end if
if (size(this,1) /= 3) then
write(*,*) 'FAIL 2:',size(this)
status = status + 1
goto 10
end if
if (maxval(abs(this - [ 1.0, 3.0, 5.0 ])) > 1.0e-6) then
write(*,*) 'FAIL 3:',abs(this)
status = status + 1
end if
10 continue
case (1)
if (size(this,1) /= 3) then
write(*,*) 'FAIL 4:',size(this)
status = status + 1
goto 20
end if
if (maxval(abs(this - [ 11.0, 12.0, 13.0 ])) > 1.0e-6) then
write(*,*) 'FAIL 5:',this
status = status + 1
end if
20 continue
case (2)
if (size(this,1) /= 4) then
write(*,*) 'FAIL 6:',size(this)
status = status + 1
goto 30
end if
if (maxval(abs(this - [ 2.0, 7.0, 12.0, 17.0 ])) > 1.0e-6) then
write(*,*) 'FAIL 7:',this
status = status + 1
end if
30 continue
end select
! if (status == 0) then
! write(*,*) 'OK'
! end if
end subroutine sa
end module mod_section_01
program section_01
use mod_section_01
implicit none
real(c_float) :: v(5,4)
integer :: i
integer :: status
v = reshape( [ (real(i), i = 1, 20) ], [ 5, 4 ] )
call si(v, 0, status)
if (status .ne. 0) stop 1
call sa(v(1:5:2, 1), 0, status)
if (status .ne. 0) stop 2
call si(v, 1, status)
if (status .ne. 0) stop 3
call sa(v(1:3, 3), 1, status)
if (status .ne. 0) stop 4
call si(v, 2, status)
if (status .ne. 0) stop 5
call sa(v(2,1:4), 2, status)
if (status .ne. 0) stop 6
end program section_01

Fortran/gfortran/regression/ISO_Fortran_binding_11.c

/* Test the fix of PR89846.
Contributed by Reinhold Bader <Bader@lrz.de>#include <stdio.h> */
#include <stdlib.h>
#include <stddef.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
typedef struct
{
char n;
float r[2];
} t1;
typedef struct
{
long int i;
t1 t1;
} t2;
void ta0(CFI_cdesc_t *);
void ta1(CFI_cdesc_t *);
void ti(CFI_cdesc_t *this, int flag)
{
int status;
size_t dis;
CFI_CDESC_T(1) that;
t1 *ans;
switch (flag)
{
case 0:
dis = offsetof(t2, t1);
status = CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other,
CFI_type_struct, sizeof(t1), 1, NULL);
if (status != CFI_SUCCESS)
{
printf("FAIL 1 establish: nonzero status %i\n",status);
exit(1);
}
status = CFI_select_part((CFI_cdesc_t *) &that, this, dis, 0);
if (status != CFI_SUCCESS)
{
printf("FAIL C1: nonzero status %i\n",status);
exit(1);
}
break;
case 1:
dis = offsetof(t2, i);
status = CFI_establish((CFI_cdesc_t *) &that, NULL, CFI_attribute_other,
CFI_type_long, 0, 1, NULL);
if (status != CFI_SUCCESS)
{
printf("FAIL 2 establish: nonzero status %i\n",status);
exit(1);
}
status = CFI_select_part((CFI_cdesc_t *) &that, this, dis, 0);
if (status != CFI_SUCCESS)
{
printf("FAIL C2: nonzero status %i\n",status);
exit(1);
}
}
if (CFI_is_contiguous((CFI_cdesc_t *) &that))
{
printf("FAIL C: contiguity for flag value %i - is %i\n",flag,
CFI_is_contiguous((CFI_cdesc_t *) &that));
}
if (flag == 0) ta0((CFI_cdesc_t *) &that);
if (flag == 1) ta1((CFI_cdesc_t *) &that);
}

Fortran/gfortran/regression/ISO_Fortran_binding_11.f90

! { dg-do run { target c99_runtime } }
! { dg-additional-sources ISO_Fortran_binding_11.c }
!
! Test the fix of PR89846.
!
! Contributed by Reinhold Bader <Bader@lrz.de>
!
module mod_subobj_01
use, intrinsic :: iso_c_binding
implicit none
integer, parameter :: nelem = 5
type, bind(c) :: t1
character(c_char) :: n
real(c_float) :: r(2)
end type t1
type, bind(c) :: t2
integer(c_long) :: i
type(t1) :: t1
end type t2
interface
subroutine ti(this, flag) bind(c)
import :: t2, c_int
type(t2) :: this(:)
integer(c_int), value :: flag
end subroutine ti
end interface
contains
subroutine ta0(this) bind(c)
type(t1) :: this(:)
integer :: i, iw, status
status = 0
if (size(this) /= nelem) then
write(*,*) 'FAIL 1: ',size(this)
status = status + 1
end if
iw = 0
do i=1, nelem
if (this(i)%n /= char(i,c_char) .or. this(i)%r(1) /= real(i,c_float) .or. &
this(i)%r(2) /= real(i+1,c_float)) then
iw = iw + 1
end if
end do
if (iw > 0) then
write(*,*) 'FAIL 2: ' ,this
status = status + 1
end if
if (status /= 0) stop 1
end subroutine ta0
subroutine ta1(this) bind(c)
integer(c_long) :: this(:)
integer :: i, status
status = 0
if (size(this) /= nelem) then
write(*,*) 'FAIL 3: ',size(this)
status = status + 1
end if
if (maxval(abs(this - [ (int(i,c_long),i=1,nelem) ])) > 0) then
write(*,*) 'FAIL 4: ' ,this
status = status + 1
end if
if (status /= 0) stop 2
end subroutine ta1
end module mod_subobj_01
program subobj_01
use mod_subobj_01
implicit none
integer :: i
type(t2), allocatable :: o_t2(:)
allocate(o_t2(nelem))
do i=1, nelem
o_t2(i)%t1 = t1( char(i,c_char), [ real(i,c_float), real(i+1,c_float) ] )
o_t2(i)%i = int(i,c_long)
end do
call ti(o_t2,0)
call ti(o_t2,1)
end program subobj_01

Fortran/gfortran/regression/ISO_Fortran_binding_12.c

/* Test the fix for PR90093. */
#include <stdio.h>
#include <math.h>
#include <ISO_Fortran_binding.h>
/* Contributed by Reinhold Bader <Bader@lrz.de> */
void foo_opt(CFI_cdesc_t *, float *, int *, int);
void write_res();
float x[34];
int main() {
CFI_CDESC_T(1) xd;
CFI_index_t ext[] = {34};
int sz;
CFI_establish((CFI_cdesc_t *) &xd, &x, CFI_attribute_other,
CFI_type_float, 0, 1, ext);
foo_opt((CFI_cdesc_t *) &xd, NULL, NULL, 0);
sz = 12;
foo_opt(NULL, &x[11], &sz, 1);
write_res();
return 0;
}

Fortran/gfortran/regression/ISO_Fortran_binding_12.f90

! { dg-do run { target c99_runtime } }
! { dg-additional-sources ISO_Fortran_binding_12.c }
!
! Test the fix for PR90093. The additional source is the main program.
!
! Contributed by Reinhold Bader <Bader@lrz.de>
!
module mod_optional
use, intrinsic :: iso_c_binding
implicit none
integer :: status = 0
contains
subroutine foo_opt(this, that, sz, flag) bind(c)
real(c_float), optional :: this(:)
real(c_float), optional :: that(*)
integer(c_int), optional :: sz
integer(c_int), value :: flag
if (flag == 0) then
if (.not. present(this) .or. present(that) .or. present(sz)) then
write(*,*) 'FAIL 1', present(this), present(that), present(sz)
status = status + 1
end if
else if (flag == 1) then
if (present(this) .or. .not. present(that) .or. .not. present(sz)) then
write(*,*) 'FAIL 2', present(this), present(that), present(sz)
status = status + 1
end if
if (sz /= 12) then
write(*,*) 'FAIL 3'
status = status + 1
end if
else if (flag == 2) then
if (present(this) .or. present(that) .or. present(sz)) then
write(*,*) 'FAIL 4', present(this), present(that), present(sz)
status = status + 1
end if
end if
end subroutine foo_opt
subroutine write_res() BIND(C)
! Add a check that the fortran missing optional is accepted by the
! bind(C) procedure.
call foo_opt (flag = 2)
if (status == 0) then
write(*,*) 'OK'
else
stop 1
end if
end subroutine
end module mod_optional

Fortran/gfortran/regression/ISO_Fortran_binding_13.c

/* Test the fix for PR91926. */
/* Contributed by José Rui Faustino de Sousa <jrfsousa@hotmail.com> */
#include <stdlib.h>
int ifb_echo(void*);
int ifb_echo(void *this)
{
return this == NULL ? 1 : 2;
}

Fortran/gfortran/regression/ISO_Fortran_binding_13.f90

! { dg-do run { target c99_runtime } }
! { dg-additional-sources ISO_Fortran_binding_13.c }
!
! Test the fix for PR91926. The additional source is the main program.
!
! Contributed by José Rui Faustino de Sousa <jrfsousa@hotmail.com>
!
program ifb_p
implicit none
integer :: i = 42
interface
integer function ifb_echo_aux(this) bind(c, name="ifb_echo")
implicit none
type(*), dimension(..), & ! removing assumed rank solves segmentation fault
optional, intent(in) :: this
end function ifb_echo_aux
end interface
if (ifb_echo_aux() .ne. 1) STOP 1 ! worked
if (ifb_echo() .ne. 1) stop 2 ! segmentation fault
if (ifb_echo_aux(i) .ne. 2) stop 3 ! worked
if (ifb_echo(i) .ne. 2) stop 4 ! worked
stop
contains
integer function ifb_echo(this)
type(*), dimension(..), &
optional, intent(in) :: this
ifb_echo = ifb_echo_aux(this)
return
end function ifb_echo
end program ifb_p

Fortran/gfortran/regression/ISO_Fortran_binding_14.f90

! { dg-do run }
!
! Correct an error in the eveluation of the CFI descriptor attribute for
! the case where the bind_C formal argument is not an assumed shape array
! and not allocatable or pointer.
!
! Contributed by Gilles Gouaillardet <gilles@rist.or.jp>
!
MODULE FOO
INTERFACE
SUBROUTINE dummy(buf) BIND(C, name="clock")
type(*), dimension(..) :: buf
END SUBROUTINE
END INTERFACE
END MODULE
PROGRAM main
USE FOO
IMPLICIT NONE
integer(8) :: before, after
INTEGER, parameter :: n = 1
INTEGER, ALLOCATABLE :: buf(:)
INTEGER :: buf2(n)
INTEGER :: i
ALLOCATE(buf(n))
before = LOC(buf(1))
CALL dummy (buf)
after = LOC(buf(1))
if (before .NE. after) stop 1
before = LOC(buf2(1))
CALL dummy (buf)
after = LOC(buf2(1))
if (before .NE. after) stop 2
END PROGRAM

Fortran/gfortran/regression/ISO_Fortran_binding_15.c

/* Test the fix for PR92123. */
/* Contributed by Vipul Parekh <parekhvs@gmail.com> */
#include <stdlib.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
// Prototype for Fortran functions
extern void Fsub(CFI_cdesc_t *);
int main()
{
/* Note: ISO C forbids zero-size array 'dim' [-Wpedantic]
Therefore, even though 'dat' represents a scalar, it is set rank 1/ */
CFI_CDESC_T(1) dat;
int irc = 0;
irc = CFI_establish((CFI_cdesc_t *)&dat, NULL,
CFI_attribute_allocatable,
CFI_type_int, 0, (CFI_rank_t)0, NULL);
if (irc != CFI_SUCCESS)
{
printf("CFI_establish failed: irc = %d.\n", irc);
return EXIT_FAILURE;
}
Fsub((CFI_cdesc_t *)&dat);
if (*(int *)dat.base_addr != 42)
{
printf("Fsub returned = %d.\n", *(int *)dat.base_addr);
return EXIT_FAILURE;
}
irc = CFI_deallocate((CFI_cdesc_t *)&dat);
if (irc != CFI_SUCCESS)
{
printf("CFI_deallocate for dat failed: irc = %d.\n", irc);
return EXIT_FAILURE;
}
return EXIT_SUCCESS;
}

Fortran/gfortran/regression/ISO_Fortran_binding_15.f90

! { dg-do run { target c99_runtime } }
! { dg-additional-sources ISO_Fortran_binding_15.c }
!
! Test the fix for PR921233. The additional source is the main program.
!
! Contributed by Vipul Parekh <parekhvs@gmail.com>
!
module m
use, intrinsic :: iso_c_binding, only : c_int
contains
subroutine Fsub( dat ) bind(C, name="Fsub")
integer(c_int), allocatable, intent(out) :: dat(..)
select rank (dat)
rank (0)
allocate( dat )
dat = 42
end select
return
end subroutine
end module m

Fortran/gfortran/regression/ISO_Fortran_binding_16.c

/* Test the fix for PR92142. */
#include <ISO_Fortran_binding.h>
#include <stdlib.h>
int c_setpointer(CFI_cdesc_t *);
int c_setpointer(CFI_cdesc_t *ip)
{
CFI_cdesc_t *yp = NULL;
void *auxp = ip->base_addr;
int ierr;
int status;
/* Setting up the pointer */
ierr = 1;
yp = malloc(sizeof(*ip));
if (yp == NULL) return ierr;
status = CFI_establish(yp, NULL, CFI_attribute_pointer, ip->type, ip->elem_len, ip->rank, NULL);
if (status != CFI_SUCCESS) return ierr;
if (yp->attribute != CFI_attribute_pointer) return ierr;
/* Set the pointer to ip */
ierr = 2;
status = CFI_setpointer(yp, ip, NULL);
if (status != CFI_SUCCESS) return ierr;
if (yp->attribute != CFI_attribute_pointer) return ierr;
/* Set the pointer to NULL */
ierr = 3;
status = CFI_setpointer(yp, NULL, NULL);
if (status != CFI_SUCCESS) return ierr;
if (yp->attribute != CFI_attribute_pointer) return ierr;
/* "Set" the ip variable to yp (should not be possible) */
ierr = 4;
status = CFI_setpointer(ip, yp, NULL);
if (status != CFI_INVALID_ATTRIBUTE) return ierr;
if (ip->attribute != CFI_attribute_other) return ierr;
if (ip->base_addr != auxp) return ierr;
return 0;
}

Fortran/gfortran/regression/ISO_Fortran_binding_16.f90

! { dg-do run }
! { dg-additional-options "-fbounds-check" }
! { dg-additional-sources ISO_Fortran_binding_16.c }
!
! Test the fix for PR92142.
!
use, intrinsic :: iso_c_binding, only: c_int
implicit none
interface
function c_setpointer(ip) result(ierr) bind(c)
use, intrinsic :: iso_c_binding, only: c_int
type(*), dimension(..), target :: ip
integer(c_int) :: ierr
end function c_setpointer
end interface
integer(c_int) :: it = 1
if (c_setpointer(it) /= 0) stop 1
end
! { dg-output "CFI_setpointer: Result shall be the address of a C descriptor for a Fortran pointer." }

Fortran/gfortran/regression/ISO_Fortran_binding_17.c

/* PR fortran/92470 - to be used with ISO_Fortran_binding_17.f90 */
#include <stdio.h>
#include <assert.h>
#include <ISO_Fortran_binding.h>
void Csub(const CFI_cdesc_t *, size_t, CFI_index_t invalid);
void Csub(const CFI_cdesc_t * dv, size_t locd, CFI_index_t invalid) {
CFI_index_t lb[1];
lb[0] = dv->dim[0].lower_bound;
size_t ld = (size_t)CFI_address(dv, lb);
if (ld != locd)
printf ("In C function: CFI_address of dv = %I64x\n", ld);
assert( ld == locd );
lb[0] = invalid;
/* Shall return NULL and produce stderr diagnostic with -fcheck=array. */
ld = (size_t)CFI_address(dv, lb);
assert (ld == 0);
return;
}

Fortran/gfortran/regression/ISO_Fortran_binding_17.f90

! { dg-do run }
! { dg-additional-sources ISO_Fortran_binding_17.c }
! { dg-options "-fcheck=all" }
! { dg-warning "command-line option '-fcheck=all' is valid for Fortran but not for C" "" { target *-*-* } 0 }
!
! PR fortran/92470
!
! https://github.com/j3-fortran/fortran_proposals/issues/57#issuecomment-552680503
!
! Unit Test #: Test-1.F2018-2.7.5
! Author : FortranFan
! Reference : The New Features of Fortran 2018, John Reid, August 2, 2018
! ISO/IEC JTC1/SC22/WG5 N2161
! Description:
! Test item 2.7.5 Fortran subscripting
! void *CFI_address(const CFI_cdesc_t *dv, const CFI_index_t subscripts[]);
! that returns the C address of a scalar or of an element of an array using
! Fortran sub-scripting.
!
use, intrinsic :: iso_c_binding, only: c_int, c_size_t, c_loc
implicit none
integer, parameter :: LB_A = -2
integer, parameter :: UB_A = 1
character(len=*), parameter :: fmtg = "(*(g0,1x))"
character(len=*), parameter :: fmth = "(g0,1x,z0)"
blk1: block
interface
subroutine Csub(a, loc_a_1, invalid_idx) bind(C, name="Csub")
import :: c_size_t
type(*), intent(in) :: a(:)
integer(c_size_t), intent(in), value :: loc_a_1, invalid_idx
end subroutine
end interface
integer(c_int), target :: a( LB_A:UB_A )
integer(c_size_t) :: loc_a
print fmtg, "Block 1"
loc_a = transfer( c_loc(a(lbound(a,dim=1))), mold=loc_a)
print fmth, "Address of a: ", loc_a
call Csub(a, loc_a, -1_c_size_t) ! LB starts at 0
call Csub(a, loc_a, 5_c_size_t) ! 4 elements + 1
print *
end block blk1
blk2: block
interface
subroutine Csub(a, loc_a_1, invalid_idx) bind(C, name="Csub")
import :: c_int, c_size_t
integer(kind=c_int), allocatable, intent(in) :: a(:)
integer(c_size_t), intent(in), value :: loc_a_1, invalid_idx
end subroutine
end interface
integer(c_int), allocatable, target :: a(:)
integer(c_size_t) :: loc_a
print fmtg, "Block 2"
allocate( a( LB_A:UB_A ) )
loc_a = transfer( c_loc(a(lbound(a,dim=1))), mold=loc_a )
print fmth, "Address of a: ", loc_a
call Csub(a, loc_a, LB_A-1_c_size_t)
call Csub(a, loc_a, UB_A+1_c_size_t)
print *
end block blk2
end
! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = -1, lower_bound = 0, upper bound = 4, extent = 4(\r*\n+)" }
! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = 5, lower_bound = 0, upper bound = 4, extent = 4(\r*\n+).*" }
! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = -3, lower_bound = -2, upper bound = 6, extent = 4(\r*\n+)" }
! { dg-output "CFI_address: subscripts\\\[0\\\] is out of bounds. For dimension = 0, subscripts = 2, lower_bound = -2, upper bound = 6, extent = 4(\r*\n+)" }

Fortran/gfortran/regression/ISO_Fortran_binding_18.c

#include <stdlib.h>
#include <string.h>
#include <ISO_Fortran_binding.h>
extern int do_loop(CFI_cdesc_t* array);
int main(int argc, char ** argv)
{
int nx = 9;
int ny = 10;
int nz = 2;
int arr[nx*ny*nz];
memset(arr,0,sizeof(int)*nx*ny*nz);
CFI_index_t shape[3];
shape[0] = nz;
shape[1] = ny;
shape[2] = nx;
CFI_CDESC_T(3) farr;
int rc = CFI_establish((CFI_cdesc_t*)&farr, arr, CFI_attribute_other, CFI_type_int, 0, (CFI_rank_t)3, (const CFI_index_t *)shape);
if (rc != CFI_SUCCESS) abort();
int result = do_loop((CFI_cdesc_t*)&farr);
if (result != nx*ny*nz) abort();
return 0;
}

Fortran/gfortran/regression/ISO_Fortran_binding_18.f90

! { dg-do run }
! { dg-additional-sources ISO_Fortran_binding_18.c }
module fortran_binding_test_18
use iso_c_binding
implicit none
contains
subroutine test(array)
integer(c_int) :: array(:)
array = 1
end subroutine
function do_loop(array) result(the_sum) bind(c)
integer(c_int), intent(in out) :: array(:,:,:)
integer(c_int) :: the_sum, i, j
the_sum = 0
array = 0
do i=1,size(array,3)
do j=1,size(array,2)
call test(array(:,j,i))
end do
end do
the_sum = sum(array)
end function
end module

Fortran/gfortran/regression/ISO_Fortran_binding_19.f90

! { dg-do run }
! This testcase failed before with optimization as
! allocatef's CFI descriptor argument 'x' failed with -fstrict-alias due to
! internally alising with the GFC descriptor
!
program testit
use iso_c_binding
implicit none (external, type)
type, bind (c) :: m
integer(C_INT) :: i, j
end type
type(m), allocatable :: a(:)
call testf (a)
contains
subroutine allocatef (x) bind (c)
type(m), allocatable :: x(:)
allocate (x(5:15))
end subroutine
subroutine testf (y)
type(m), allocatable, target :: y(:)
call allocatef (y)
if (.not. allocated (y)) stop 1
end subroutine
end program

Fortran/gfortran/regression/ISO_Fortran_binding_3.c

#include <ISO_Fortran_binding.h>
#include <stdio.h>
#include <stdlib.h>
/* Part of the test for the fix of PR88929 - see ISO_Fortran_binding_3.f90. */
int c_test (CFI_cdesc_t * a_desc)
{
CFI_index_t idx[2];
int *res_addr;
int err = 1; /* this error code represents all errors */
if (a_desc->rank != 2)
return err;
if (a_desc->type != CFI_type_int)
return err;
err = 0;
for (idx[0] = 0; idx[0] < a_desc->dim[0].extent; idx[0]++)
for (idx[1] = 0; idx[1] < a_desc->dim[1].extent; idx[1]++)
{
res_addr = CFI_address (a_desc, idx);
err += *res_addr;
*res_addr = *res_addr + 1;
}
if (err != 10) return 1;
return 0;
}

Fortran/gfortran/regression/ISO_Fortran_binding_3.f90

! { dg-do run }
! { dg-additional-sources ISO_Fortran_binding_3.c }
!
! Test the fix for PR88929.
!
integer, dimension (:,:), allocatable :: actual
integer, dimension(2,2) :: src = reshape ([1,2,3,4], [2,2])
allocate (actual, source = src)
ier = test1 (actual)
if (ier .ne. 0) stop 1
if (any (actual .ne. src + 1)) stop 2
contains
function test1 (arg) RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
INTEGER(C_INT) :: err
type(*), dimension(..), intent(inout) :: arg
interface
function test_c (a) BIND(C, NAME="c_test") RESULT(err)
USE, INTRINSIC :: ISO_C_BINDING
type(*), dimension(..), intent(inout) :: a
INTEGER(C_INT) :: err
end function
end interface
err = test_c (arg) ! This used to ICE
end function test1
end

Fortran/gfortran/regression/ISO_Fortran_binding_4.f90

! { dg-do run }
! PR fortran/89384 - this used to give a wrong results
! with contiguous.
! The subroutine substr is a test to check a problem found while
! debugging PR90355.
!
! Test case by Reinhold Bader.
!
module mod_ctg
implicit none
contains
subroutine ctg(x) BIND(C)
real, contiguous :: x(:)
if (any(abs(x - [2.,4.,6.]) > 1.e-6)) stop 1
x = [2.,4.,6.]*10.0
end subroutine
subroutine substr(str) BIND(C)
character(*) :: str(:)
if (str(1) .ne. "bcd") stop 2
if (str(2) .ne. "ghi") stop 3
str = ['uvw','xyz']
end subroutine
subroutine substr4(str4) BIND(C)
character(*, kind=4) :: str4(:)
print *, str4(1)
print *, str4(2)
if (str4(1) .ne. 4_"bcd") stop 4
if (str4(2) .ne. 4_"ghi") stop 5
str4 = [4_'uvw', 4_'xyz']
end subroutine
end module
program p
use mod_ctg
implicit none
real :: x(6)
character(5) :: str(2) = ['abcde', 'fghij']
character(5, kind=4) :: str4(2) = [4_'abcde', 4_'fghij']
integer :: i
x = [ (real(i), i=1, size(x)) ]
call ctg(x(2::2))
if (any (abs (x - [1.,20.,3.,40.,5.,60.]) > 1.e-6)) stop 3
!call substr(str(:)(2:4))
!if (any (str .ne. ['auvwe','fxyzj'])) stop 4
call substr4(str4(:)(2:4))
if (any (str4 .ne. [4_'auvwe', 4_'fxyzj'])) stop 4
end program

Fortran/gfortran/regression/ISO_Fortran_binding_5.c

/* Test fix for PR89385. */
/* Contributed by Reinhold Bader <Bader@lrz.de> */
#include <stdio.h>
#include <math.h>
#include <ISO_Fortran_binding.h>
typedef struct {
int i;
float r[2];
} cstruct;
void Psub(CFI_cdesc_t *this, CFI_cdesc_t *that, int *ierr) {
int status = 0;
cstruct *cu;
float *ct;
CFI_dim_t *dim;
if (this->elem_len != sizeof(float)) {
printf("FAIL: this->elem_len %i\n",(int) this->elem_len);
status++;
}
if (this->type != CFI_type_float) {
printf("FAIL: this->type\n");
status++;
}
if (this->rank != 2) {
printf("FAIL: this->rank %i\n",this->rank);
status++;
}
if (this->attribute != CFI_attribute_allocatable) {
printf("FAIL: this->attribute\n");
status++;
}
dim = this->dim;
if (dim[0].lower_bound != 3 || dim[0].extent != 4) {
printf("FAIL: dim[0] %d %d\n", dim[0].lower_bound, dim[0].extent);
status++;
}
if (dim[1].lower_bound != 1 || dim[1].extent != 5) {
printf("FAIL: dim[1] %d %d\n", dim[1].lower_bound, dim[1].extent);
status++;
}
if (that->elem_len != sizeof(cstruct)) {
printf("FAIL: that->elem_len\n");
status++;
}
if (that->type != CFI_type_struct) {
printf("FAIL: that->type %d %d\n", that->type, CFI_type_struct);
status++;
}
if (that->rank != 1) {
printf("FAIL: that->rank\n");
status++;
}
if (that->attribute != CFI_attribute_allocatable) {
printf("FAIL: that->attribute\n");
status++;
}
dim = that->dim;
if (dim[0].lower_bound != 1 || dim[0].extent != 1) {
printf("FAIL: dim[0] %d %d\n" , dim[0].lower_bound, dim[0].extent);
status++;
}
cu = (cstruct *) ((CFI_cdesc_t *) that)->base_addr;
if (cu->i != 4 || fabs(cu->r[1] - 2.2) > 1.0e-6) {
printf("FAIL: value of that %i %f %f\n",cu->i,cu->r[1],cu->r[2]);
status++;
}
ct = (float *) ((CFI_cdesc_t *) this)->base_addr;
if ( fabs(ct[5] + 2.0) > 1.0e-6) {
printf("FAIL: value of this %f\n",ct[5]);
status++;
}
*ierr = status;
}

Fortran/gfortran/regression/ISO_Fortran_binding_5.f90

! { dg-do run }
! { dg-additional-sources ISO_Fortran_binding_5.c }
!
! Test fix of PR89385.
!
! Contributed by Reinhold Bader <Bader@lrz.de>
!
program allocatable_01
use, intrinsic :: iso_c_binding
implicit none
type, bind(c) :: cstruct
integer(c_int) :: i
real(c_float) :: r(2)
end type cstruct
interface
subroutine psub(this, that, ierr) bind(c, name='Psub')
import :: c_float, cstruct, c_int
real(c_float), allocatable :: this(:,:)
type(cstruct), allocatable :: that(:)
integer(c_int), intent(inout) :: ierr
end subroutine psub
end interface
real(c_float), allocatable :: t(:,:)
type(cstruct), allocatable :: u(:)
integer(c_int) :: ierr
allocate(t(3:6,5))
t = 0.0
t(4,2) = -2.0
allocate(u(1), source=[ cstruct( 4, [1.1,2.2] ) ] )
call psub(t, u, ierr)
deallocate(t,u)
if (ierr .ne. 0) stop ierr
end program allocatable_01

Fortran/gfortran/regression/ISO_Fortran_binding_6.c

/* Test fix for PR89366. */
/* Contributed by Reinhold Bader <Bader@lrz.de> */
#include <stdio.h>
#include <math.h>
#include <ISO_Fortran_binding.h>
#define DEBUG 0
void process_string(CFI_cdesc_t *this, int *ierr) {
char *cstr;
cstr = (char *) this->base_addr;
*ierr = 0;
if (this->rank != 0) {
*ierr = 1;
return;
}
if (DEBUG == 1) {
printf("elem_len member has value %i %s\n",this->elem_len, cstr);
}
}

Fortran/gfortran/regression/ISO_Fortran_binding_6.f90

! { dg-do run }
! { dg-additional-sources ISO_Fortran_binding_6.c }
!
! Test fix of PR89366.
!
! Contributed by Reinhold Bader <Bader@lrz.de>
!
program assumed_length_01
use, intrinsic :: iso_c_binding
implicit none
integer, parameter :: strlen = 12
integer(c_int) :: ierr(3)
character(kind=c_char,len=strlen) :: s1
character(kind=c_char,len=:), allocatable :: s2
character(kind=c_char,len=:), pointer :: s3
!
! invoke a C function that processes an assumed length string
interface
subroutine process_string(this, ierr) BIND(C)
import :: c_char, c_int
character(kind=c_char,len=*), intent(in) :: this(..)
integer(c_int), intent(inout) :: ierr
end subroutine process_string
end interface
!
!
ierr = 0
s1 = c_char_'wrzlprmft' // c_null_char
call process_string(s1, ierr(1))
if (ierr(1) /= 0) stop 1
s2 = c_char_'wrzlprmft' // c_null_char
allocate(s3, source=trim(s1))
call process_string(s2, ierr(2))
if (ierr(2) /= 0) stop 2
call process_string(s3, ierr(3))
if (ierr(3) /= 0) stop 3
if (sum(abs(ierr)) == 0) write(*,*) 'OK'
deallocate(s2,s3)
end program assumed_length_01

Fortran/gfortran/regression/ISO_Fortran_binding_7.c

/* Test the fix for PR89841. */
/* Contributed by Reinhold Bader <Bader@lrz.de> */
#include <ISO_Fortran_binding.h>
#include <stdio.h>
#include <stdlib.h>
#include <math.h>
typedef struct
{
int i;
float r[2];
} cstruct;
int Psuba(CFI_cdesc_t *this, CFI_cdesc_t *that, int Dcase) {
int status = 0;
cstruct *cu;
float *ct;
CFI_dim_t *dim;
if (this->elem_len != sizeof(float))
{
printf("FAIL: Dcase %i - this->elem_len %i\n",Dcase, (int) this->elem_len);
status++;
}
if (this->type != CFI_type_float)
{
printf("FAIL: Dcase %i - this->type\n", Dcase);
status++;
}
if (this->rank != 2)
{
printf("FAIL: Dcase %i - this->rank %i\n",Dcase,this->rank);
status++;
}
if (this->attribute != CFI_attribute_other)
{
printf("FAIL: Dcase %i - this->attribute\n", Dcase);
status++;
}
dim = this->dim;
if (dim[0].lower_bound != 0 || dim[0].extent != 3)
{
printf("FAIL: Dcase %i - dim[0] %i %i %i\n",Dcase, (int) dim[0].lower_bound,
(int)dim[0].extent,(int)dim[0].sm);
status++;
}
if (dim[1].lower_bound != 0 || dim[1].extent != 7)
{
printf("FAIL: Dcase %i - dim[1] %i %i %i\n",Dcase,(int) dim[1].lower_bound,
(int) dim[1].extent,(int) dim[1].sm);
status++;
}
if (that->elem_len != sizeof(cstruct))
{
printf("FAIL: Dcase %i - that->elem_len\n", Dcase);
status++;
}
if (that->type != CFI_type_struct)
{
printf("FAIL: Dcase %i - that->type\n",Dcase);
status++;
}
if (that->rank != 1)
{
printf("FAIL: Dcase %i - that->rank\n", Dcase);
status++;
}
if (that->attribute != CFI_attribute_other)
{
printf("FAIL: Dcase %i - that->attribute %i\n",Dcase,that->attribute);
status++;
}
dim = that->dim;
if (dim[0].lower_bound != 0 || dim[0].extent != 1)
{
printf("FAIL: Dcase %i - dim[0] %i %i\n",Dcase,(int)dim[0].lower_bound,dim[0].extent);
status++;
}
cu = (cstruct *) ((CFI_cdesc_t *) that)->base_addr;
if (cu->i != 4 || fabs(cu->r[1] - 2.2) > 1.0e-6)
{
printf("FAIL: Dcase %i - value of that %i %f %f\n",Dcase,cu->i,cu->r[0],cu->r[1]);
status++;
}
ct = (float *) ((CFI_cdesc_t *) this)->base_addr;
if ( fabs(ct[5] + 2.0) > 1.0e-6)
{
printf("FAIL: Dcase %i - value of this %f\n",Dcase,ct[5]);
status++;
}
return status;
}

Fortran/gfortran/regression/ISO_Fortran_binding_7.f90

! { dg-do run { target c99_runtime } }
! { dg-additional-sources ISO_Fortran_binding_7.c }
!
! Test the fix for PR89841.
!
! Contributed by Reinhold Bader <Bader@lrz.de>
!
program assumed_shape_01
use, intrinsic :: iso_c_binding
implicit none
type, bind(c) :: cstruct
integer(c_int) :: i
real(c_float) :: r(2)
end type cstruct
interface
function psub(this, that, case) bind(c, name='Psuba') result(status)
import :: c_float, c_int, cstruct
real(c_float) :: this(:,:)
type(cstruct) :: that(:)
integer(c_int), value :: case
integer(c_int) :: status
end function psub
end interface
real(c_float) :: t(3,7)
type(cstruct), pointer :: u(:)
type(cstruct), allocatable :: v(:)
integer(c_int) :: st
allocate(u(1), source=[cstruct( 4, [1.1,2.2] ) ])
allocate(v(1), source=[cstruct( 4, [1.1,2.2] ) ])
t = 0.0
t(3,2) = -2.0
st = psub(t, u, 1)
if (st .ne. 0) stop 1
st = psub(t, v, 2)
if (st .ne. 0) stop 2
deallocate (u)
deallocate (v)
end program assumed_shape_01

Fortran/gfortran/regression/ISO_Fortran_binding_8.c

/* Test the fix for PR89841. */
/* Contributed by Reinhold Bader <Bader@lrz.de> */
#include <ISO_Fortran_binding.h>
#include <stdio.h>
float Cxgl[] = { 1.1, 2.3, 5.1, 4.2 };
void globalp(CFI_cdesc_t *this)
{
int i, status;
float *pt;
CFI_index_t lb[] = { 3 };
CFI_index_t ub[] = { 6 };
if (this->base_addr == NULL)
{
status = CFI_allocate(this, lb, ub, 0);
}
else
{
printf("FAIL C: already allocated.\n");
return;
}
if (status != CFI_SUCCESS)
{
printf("FAIL C: status is %i\n",status);
}
pt = (float *) this->base_addr;
for (i=0; i<4; i++)
{
pt[i] = Cxgl[i];
}
}

Fortran/gfortran/regression/ISO_Fortran_binding_8.f90

! { dg-do run { target c99_runtime } }
! { dg-additional-sources ISO_Fortran_binding_8.c }
!
! Test the fix for PR89842.
!
! Contributed by Reinhold Bader <Bader@lrz.de>
!
module mod_alloc_01
use, intrinsic :: iso_c_binding
implicit none
interface
subroutine globalp(this) bind(c)
import :: c_float
real(c_float), allocatable :: this(:)
end subroutine globalp
end interface
end module mod_alloc_01
program alloc_01
use mod_alloc_01
implicit none
real(c_float), allocatable :: myp(:)
integer :: status
status = 0
call globalp(myp)
! write(*,*) 'globalp done'
if (.not. allocated(myp)) then
write(*,*) 'FAIL 1'
stop 1
end if
if (lbound(myp,1) /= 3 .or. size(myp,1) /= 4) then
write(*,*) 'FAIL 2: ', lbound(myp), size(myp,1)
status = status + 1
else
! write(*,*) 'Now checking data', myp(3)
if (maxval(abs(myp - [1.1, 2.3, 5.1, 4.2])) > 1.0e-6) then
write(*,*) 'FAIL 3: ', myp
status = status + 1
end if
end if
if (status .ne. 0) then
stop status
end if
end program alloc_01

Fortran/gfortran/regression/ISO_Fortran_binding_9.c

/* Test fix of a problem with CFI_is_contiguous. */
/* Contributed by Gilles Gouaillardet <gilles@rist.or.jp> */
#include <ISO_Fortran_binding.h>
#include <stdlib.h>
int cdesc_c(CFI_cdesc_t* x, long *expected)
{
int res;
res = CFI_is_contiguous (x);
if (x->base_addr != (void *)*expected) res = 0;
return res;
}
No newline at end of file

Fortran/gfortran/regression/ISO_Fortran_binding_9.f90

! { dg-do run { target c99_runtime } }
! { dg-additional-sources ISO_Fortran_binding_9.c }
!
! Fix a problem with CFI_is_contiguous
!
! Contributed by Gilles Gouaillardet <gilles@rist.or.jp>
!
module cdesc
interface
function cdesc_f08(buf, expected) result (res) BIND(C, name="cdesc_c")
USE, INTRINSIC :: ISO_C_BINDING
implicit none
INTEGER(C_INT) :: res
type(*), dimension(..), INTENT(IN) :: buf
integer(kind=kind(loc(res))),INTENT(IN) :: expected
end function cdesc_f08
end interface
end module
program cdesc_test
use cdesc
implicit none
integer :: a0, a1(10), a2(10,10), a3(10,10,10)
if (cdesc_f08(a0, LOC(a0)) .ne. 1) stop 1
if (cdesc_f08(a1, LOC(a1(1))) .ne. 1) stop 2
if (cdesc_f08(a2, LOC(a2(1,1))) .ne. 1) stop 3
if (cdesc_f08(a3, LOC(a3(1,1,1))) .ne. 1) stop 4
end program

Fortran/gfortran/regression/PR100029.f90

! { dg-do run }
!
! Test the fix for PR100029
!
program foo_p
implicit none
type :: foo_t
end type foo_t
class(foo_t), allocatable :: pout
call foo_s(pout)
contains
subroutine foo_s(that)
class(foo_t), allocatable, intent(out) :: that(..)
end subroutine foo_s
end program foo_p

Fortran/gfortran/regression/PR100040.f90

! { dg-do run }
!
! Test the fix for PR100040
!
program foo_p
implicit none
integer, parameter :: n = 11
type :: foo_t
integer :: i
end type foo_t
type(foo_t), parameter :: a = foo_t(n)
class(foo_t), allocatable :: pout
call foo_s(pout)
if(.not.allocated(pout)) stop 1
if(pout%i/=n) stop 2
contains
subroutine foo_s(that)
class(foo_t), allocatable, intent(out) :: that(..)
select rank(that)
rank(0)
that = a
rank default
stop 3
end select
end subroutine foo_s
end program foo_p

Fortran/gfortran/regression/PR100094.f90

! { dg-do run }
!
! Test the fix for PR100094
!
program foo_p
implicit none
integer, parameter :: n = 11
integer, pointer :: pout(:)
integer, target :: a(n)
integer :: i
a = [(i, i=1,n)]
call foo(pout)
if(.not.associated(pout)) stop 1
if(.not.associated(pout, a)) stop 2
if(any(pout/=a)) stop 3
stop
contains
subroutine foo(that)
integer, pointer, intent(out) :: that(..)
select rank(that)
rank(1)
that => a
rank default
stop 4
end select
return
end subroutine foo
end program foo_p

Fortran/gfortran/regression/PR100097.f90

! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! Test the fix for PR100097
!
program main_p
implicit none
class(*), pointer :: bar_p(:)
class(*), allocatable :: bar_a(:)
call foo_p(bar_p)
call foo_a(bar_a)
contains
subroutine foo_p(that)
class(*), pointer, intent(out) :: that(..)
select rank(that)
rank(1)
rank default
stop 1
end select
end subroutine foo_p
subroutine foo_a(that)
class(*), allocatable, intent(out) :: that(..)
select rank(that)
rank(1)
rank default
stop 2
end select
end subroutine foo_a
end program main_p
! { dg-final { scan-tree-dump "bar_a._data.dtype = \\{.* .rank=1,.*\\}" "original" } }
! { dg-final { scan-tree-dump "bar_p._data.dtype = \\{.* .rank=1,.*\\}" "original" } }

Fortran/gfortran/regression/PR100098.f90

! { dg-do run }
! { dg-options "-fdump-tree-original" }
!
! Test the fix for PR100098
!
program main_p
implicit none
type :: foo_t
integer :: i
end type foo_t
class(foo_t), pointer :: bar_p(:)
class(foo_t), allocatable :: bar_a(:)
call foo_p(bar_p)
call foo_a(bar_a)
contains
subroutine foo_p(that)
class(foo_t), pointer, intent(out) :: that(..)
select rank(that)
rank(1)
rank default
stop 1
end select
end subroutine foo_p
subroutine foo_a(that)
class(foo_t), allocatable, intent(out) :: that(..)
select rank(that)
rank(1)
rank default
stop 2
end select
end subroutine foo_a
end program main_p
! { dg-final { scan-tree-dump "bar_a._data.dtype = \\{.* .rank=1,.*\\}" "original" } }
! { dg-final { scan-tree-dump "bar_p._data.dtype = \\{.* .rank=1,.*\\}" "original" } }

Fortran/gfortran/regression/PR100103.f90

! { dg-do run }
!
! Test the fix for PR100103
!
program main_p
implicit none
integer :: i
integer, parameter :: n = 11
type :: foo_t
integer :: i
end type foo_t
type(foo_t), parameter :: a(*) = [(foo_t(i), i=1,n)]
type(foo_t), allocatable :: bar_d(:)
class(foo_t), allocatable :: bar_p(:)
class(*), allocatable :: bar_u(:)
call foo_d(bar_d)
if(.not.allocated(bar_d)) stop 1
if(any(bar_d%i/=a%i)) stop 2
deallocate(bar_d)
call foo_p(bar_p)
if(.not.allocated(bar_p)) stop 3
if(any(bar_p%i/=a%i)) stop 4
deallocate(bar_p)
call foo_u(bar_u)
if(.not.allocated(bar_u)) stop 5
select type(bar_u)
type is(foo_t)
if(any(bar_u%i/=a%i)) stop 6
class default
stop 7
end select
deallocate(bar_u)
contains
subroutine foo_d(that)
type(foo_t), allocatable, intent(out) :: that(..)
select rank(that)
rank(1)
that = a
rank default
stop 8
end select
end subroutine foo_d
subroutine foo_p(that)
class(foo_t), allocatable, intent(out) :: that(..)
select rank(that)
rank(1)
that = a
rank default
stop 9
end select
end subroutine foo_p
subroutine foo_u(that)
class(*), allocatable, intent(out) :: that(..)
select rank(that)
rank(1)
that = a
rank default
stop 10
end select
end subroutine foo_u
end program main_p

Fortran/gfortran/regression/PR100120.f90

! { dg-do run }
!
! Tests fix for PR100120
!
program main_p
implicit none
integer, parameter :: n = 11
integer, parameter :: m = 7
integer, parameter :: c = 63
type :: foo_t
integer :: i
end type foo_t
type, extends(foo_t) :: bar_t
integer :: j(n)
end type bar_t
integer, target :: ain(n)
character, target :: ac1(n)
character(len=m), target :: acn(n)
type(foo_t), target :: afd(n)
type(bar_t), target :: abd(n)
!
class(foo_t), pointer :: spf
class(foo_t), pointer :: apf(:)
class(bar_t), pointer :: spb
class(bar_t), pointer :: apb(:)
class(*), pointer :: spu
class(*), pointer :: apu(:)
integer :: i, j
ain = [(i, i=1,n)]
ac1 = [(achar(i+c), i=1,n)]
do i = 1, n
do j = 1, m
acn(i)(j:j) = achar(i*m+j+c-m)
end do
end do
afd%i = ain
abd%i = ain
do i = 1, n
abd(i)%j = 2*i*ain
end do
!
spf => afd(n)
if(.not.associated(spf)) stop 1
if(.not.associated(spf, afd(n))) stop 2
if(spf%i/=n) stop 3
apf => afd
if(.not.associated(apf)) stop 4
if(.not.associated(apf, afd)) stop 5
if(any(apf%i/=afd%i)) stop 6
!
spf => abd(n)
if(.not.associated(spf)) stop 7
if(.not.associated(spf, abd(n))) stop 8
if(spf%i/=n) stop 9
select type(spf)
type is(bar_t)
if(any(spf%j/=2*n*ain)) stop 10
class default
stop 11
end select
apf => abd
if(.not.associated(apf)) stop 12
if(.not.associated(apf, abd)) stop 13
if(any(apf%i/=abd%i)) stop 14
select type(apf)
type is(bar_t)
do i = 1, n
if(any(apf(i)%j/=2*i*ain)) stop 15
end do
class default
stop 16
end select
!
spb => abd(n)
if(.not.associated(spb)) stop 17
if(.not.associated(spb, abd(n))) stop 18
if(spb%i/=n) stop 19
if(any(spb%j/=2*n*ain)) stop 20
apb => abd
if(.not.associated(apb)) stop 21
if(.not.associated(apb, abd)) stop 22
if(any(apb%i/=abd%i)) stop 23
do i = 1, n
if(any(apb(i)%j/=2*i*ain)) stop 24
end do
!
spu => ain(n)
if(.not.associated(spu)) stop 25
if(.not.associated(spu, ain(n))) stop 26
select type(spu)
type is(integer)
if(spu/=n) stop 27
class default
stop 28
end select
apu => ain
if(.not.associated(apu)) stop 29
if(.not.associated(apu, ain)) stop 30
select type(apu)
type is(integer)
if(any(apu/=ain)) stop 31
class default
stop 32
end select
!
spu => ac1(n)
if(.not.associated(spu)) stop 33
if(.not.associated(spu, ac1(n))) stop 34
select type(spu)
type is(character(len=*))
if(len(spu)/=1) stop 35
if(spu/=ac1(n)) stop 36
class default
stop 37
end select
apu => ac1
if(.not.associated(apu)) stop 38
if(.not.associated(apu, ac1)) stop 39
select type(apu)
type is(character(len=*))
if(len(apu)/=1) stop 40
if(any(apu/=ac1)) stop 41
class default
stop 42
end select
!
spu => acn(n)
if(.not.associated(spu)) stop 43
if(.not.associated(spu, acn(n))) stop 44
select type(spu)
type is(character(len=*))
if(len(spu)/=m) stop 45
if(spu/=acn(n)) stop 46
class default
stop 47
end select
apu => acn
if(.not.associated(apu)) stop 48
if(.not.associated(apu, acn)) stop 49
select type(apu)
type is(character(len=*))
if(len(apu)/=m) stop 50
if(any(apu/=acn)) stop 51
class default
stop 52
end select
!
spu => afd(n)
if(.not.associated(spu)) stop 53
if(.not.associated(spu, afd(n))) stop 54
select type(spu)
type is(foo_t)
if(spu%i/=n) stop 55
class default
stop 56
end select
apu => afd
if(.not.associated(apu)) stop 57
if(.not.associated(apu, afd)) stop 58
select type(apu)
type is(foo_t)
if(any(apu%i/=afd%i)) stop 59
class default
stop 60
end select
!
spu => abd(n)
if(.not.associated(spu)) stop 61
if(.not.associated(spu, abd(n))) stop 62
select type(spu)
type is(bar_t)
if(spu%i/=n) stop 63
if(any(spu%j/=2*n*ain)) stop 64
class default
stop 65
end select
apu => abd
if(.not.associated(apu)) stop 66
if(.not.associated(apu, abd)) stop 67
select type(apu)
type is(bar_t)
if(any(apu%i/=abd%i)) stop 68
do i = 1, n
if(any(apu(i)%j/=2*i*ain)) stop 69
end do
class default
stop 70
end select
stop
end program main_p

Fortran/gfortran/regression/PR100132.f90

! { dg-do run }
!
! Test the fix for PR100132
!
module main_m
implicit none
private
public :: &
foo_t
public :: &
set, &
get
type :: foo_t
integer :: i
end type foo_t
type(foo_t), save, pointer :: data => null()
contains
subroutine set(this)
class(foo_t), pointer, intent(in) :: this
if(associated(data)) stop 1
data => this
end subroutine set
subroutine get(this)
type(foo_t), pointer, intent(out) :: this
if(.not.associated(data)) stop 4
this => data
nullify(data)
end subroutine get
end module main_m
program main_p
use :: main_m, only: &
foo_t, set, get
implicit none
integer, parameter :: n = 1000
type(foo_t), pointer :: ps
type(foo_t), target :: s
integer :: i, j, yay, nay
yay = 0
nay = 0
do i = 1, n
s%i = i
call set(s)
call get(ps)
if(.not.associated(ps)) stop 13
j = ps%i
if(i/=j) stop 14
if(i/=s%i) stop 15
if(ps%i/=s%i) stop 16
if(associated(ps, s))then
yay = yay + 1
else
nay = nay + 1
end if
end do
if((yay/=n).or.(nay/=0)) stop 17
end program main_p

Fortran/gfortran/regression/PR100136.f90

! { dg-do run }
! { dg-options "-fcheck=pointer" }
! { dg-shouldfail "Argument not allocated" }
! { dg-output "Fortran runtime error: Allocatable actual argument 'c_init2' is not allocated" }
!
! Tests fix for PR100136
!
! Test cut down from PR58586
!
module test_pr58586_mod
implicit none
type :: a
end type
type :: c
type(a), allocatable :: a
end type
contains
subroutine add_class_c (d)
class(c), value :: d
end subroutine
class(c) function c_init2()
allocatable :: c_init2
end function
end module test_pr58586_mod
program test_pr58586
use test_pr58586_mod
! This needs to execute, to see whether the segfault at runtime is resolved
call add_class_c(c_init2())
end program

Fortran/gfortran/regression/PR10018.f90

! { dg-do compile }
!
subroutine foo(that)
implicit none
class(*), target, intent(in) :: this
class(*), pointer, intent(out) :: that
that => this
return
end subroutine foo
! { dg-error "Symbol at \\\(1\\\) is not a DUMMY variable" "" { target "*-*-*" } 5 }

Fortran/gfortran/regression/PR100245.f90

! { dg-do run }
!
! Test the fix for PR100245
!
program main_p
implicit none
type :: foo_t
integer :: a
end type foo_t
integer, parameter :: a = 42
class(foo_t), allocatable :: val
class(foo_t), allocatable :: rs1
type(foo_t), allocatable :: rs2
allocate(val, source=foo_t(42))
if (val%a/=a) stop 1
rs1 = val
if (rs1%a/=a) stop 2
rs2 = val
if (rs2%a/=a) stop 3
deallocate(val, rs1, rs2)
end program main_p

Fortran/gfortran/regression/PR100906.c

/* Test the fix for PR100906 */
#include <assert.h>
#include <stdbool.h>
#include <stdint.h>
#include <stdio.h>
/* #include <uchar.h> */
#include <ISO_Fortran_binding.h>
#define _CFI_type_mask 0xFF
#define _CFI_type_kind_shift 8
#define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask)
#define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask)
#define _CFI_encode_type(TYPE, KIND) (int16_t)\
((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\
| ((TYPE) & CFI_type_mask))
#define N 11
#define M 7
typedef char c_char;
/* typedef char32_t c_ucs4_char; */
typedef uint32_t char32_t;
typedef uint32_t c_ucs4_char;
bool charcmp (char *, char, size_t);
bool ucharcmp (char32_t *, char32_t, size_t);
bool c_vrfy_c_char (const CFI_cdesc_t *restrict, const size_t);
bool c_vrfy_c_ucs4_char (const CFI_cdesc_t *restrict, const size_t);
bool c_vrfy_character (const CFI_cdesc_t *restrict, const size_t);
void check_tk (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t);
bool
charcmp (char *c, char v, size_t n)
{
bool res = true;
char b = (char)'A';
size_t i;
for (i=0; ((i<n)&&(res)); i++, c++)
res = (*c == (v+b));
return res;
}
bool
ucharcmp (char32_t *c, char32_t v, size_t n)
{
bool res = true;
char32_t b = (char32_t)0xFF01;
size_t i;
for (i=0; ((i<n)&&(res)); i++, c++)
res = (*c == (v+b));
return res;
}
bool
c_vrfy_c_char (const CFI_cdesc_t *restrict auxp, const size_t len)
{
CFI_index_t i, lb, ub, ex;
size_t sz;
c_char *ip = NULL;
assert (auxp);
assert (auxp->base_addr);
assert (auxp->elem_len>0);
lb = auxp->dim[0].lower_bound;
ex = auxp->dim[0].extent;
assert (ex==N);
sz = (size_t)auxp->elem_len / sizeof (c_char);
assert (sz==len);
ub = ex + lb - 1;
ip = (c_char*)auxp->base_addr;
for (i=0; i<ex; i++, ip+=sz)
if (!charcmp (ip, (c_char)(i), sz))
return false;
for (i=lb; i<ub+1; i++)
{
ip = (c_char*)CFI_address(auxp, &i);
if (!charcmp (ip, (c_char)(i-lb), sz))
return false;
}
return true;
}
bool
c_vrfy_c_ucs4_char (const CFI_cdesc_t *restrict auxp, const size_t len)
{
CFI_index_t i, lb, ub, ex;
size_t sz;
c_ucs4_char *ip = NULL;
assert (auxp);
assert (auxp->base_addr);
assert (auxp->elem_len>0);
lb = auxp->dim[0].lower_bound;
ex = auxp->dim[0].extent;
assert (ex==N);
sz = (size_t)auxp->elem_len / sizeof (c_ucs4_char);
assert (sz==len);
ub = ex + lb - 1;
ip = (c_ucs4_char*)auxp->base_addr;
for (i=0; i<ex; i++, ip+=sz)
if (!ucharcmp (ip, (c_ucs4_char)(i), sz))
return false;
for (i=lb; i<ub+1; i++)
{
ip = (c_ucs4_char*)CFI_address(auxp, &i);
if (!ucharcmp (ip, (c_ucs4_char)(i-lb), sz))
return false;
}
return true;
}
bool
c_vrfy_character (const CFI_cdesc_t *restrict auxp, const size_t len)
{
signed char type, kind;
assert (auxp);
type = _CFI_decode_type(auxp->type);
kind = _CFI_decode_kind(auxp->type);
assert (type == CFI_type_Character);
switch (kind)
{
case 1:
return c_vrfy_c_char (auxp, len);
break;
case 4:
return c_vrfy_c_ucs4_char (auxp, len);
break;
default:
assert (false);
}
return true;
}
void
check_tk (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed char kind, const size_t elem_len, const size_t nelem)
{
signed char ityp, iknd;
assert (auxp);
assert (auxp->elem_len==elem_len*nelem);
assert (auxp->rank==1);
assert (auxp->dim[0].sm>0);
assert ((size_t)auxp->dim[0].sm==elem_len*nelem);
/* */
assert (auxp->type==type);
ityp = _CFI_decode_type(auxp->type);
assert (ityp == CFI_type_Character);
iknd = _CFI_decode_kind(auxp->type);
assert (_CFI_decode_type(type)==ityp);
assert (kind==iknd);
assert (c_vrfy_character (auxp, nelem));
return;
}
// Local Variables:
// mode: C
// End:

Fortran/gfortran/regression/PR100906.f90

! { dg-do run }
! { dg-additional-sources PR100906.c }
!
! Test the fix for PR100906
!
module isof_m
use, intrinsic :: iso_c_binding, only: &
c_signed_char, c_int16_t
implicit none
private
public :: &
CFI_type_character
public :: &
CFI_type_char, &
CFI_type_ucs4_char
public :: &
check_tk_as, &
check_tk_ar
public :: &
cfi_encode_type
integer, parameter :: CFI_type_t = c_int16_t
integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t)
integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t
! Intrinsic types. Their kind number defines their storage size. */
integer(kind=c_signed_char), parameter :: CFI_type_Character = 5
! C-Fortran Interoperability types.
integer(kind=cfi_type_t), parameter :: CFI_type_char = &
ior(int(CFI_type_Character, kind=c_int16_t), shiftl(1_c_int16_t, CFI_type_kind_shift))
integer(kind=cfi_type_t), parameter :: CFI_type_ucs4_char = &
ior(int(CFI_type_Character, kind=c_int16_t), shiftl(4_c_int16_t, CFI_type_kind_shift))
interface
subroutine check_tk_as(a, t, k, e, n) &
bind(c, name="check_tk")
use, intrinsic :: iso_c_binding, only: &
c_int16_t, c_signed_char, c_size_t
implicit none
type(*), intent(in) :: a(:)
integer(c_int16_t), value, intent(in) :: t
integer(c_signed_char), value, intent(in) :: k
integer(c_size_t), value, intent(in) :: e
integer(c_size_t), value, intent(in) :: n
end subroutine check_tk_as
subroutine check_tk_ar(a, t, k, e, n) &
bind(c, name="check_tk")
use, intrinsic :: iso_c_binding, only: &
c_int16_t, c_signed_char, c_size_t
implicit none
type(*), intent(in) :: a(..)
integer(c_int16_t), value, intent(in) :: t
integer(c_signed_char), value, intent(in) :: k
integer(c_size_t), value, intent(in) :: e
integer(c_size_t), value, intent(in) :: n
end subroutine check_tk_ar
end interface
contains
elemental function cfi_encode_type(type, kind) result(itype)
integer(kind=c_signed_char), intent(in) :: type
integer(kind=c_signed_char), intent(in) :: kind
integer(kind=c_int16_t) :: itype, ikind
itype = int(type, kind=c_int16_t)
itype = iand(itype, CFI_type_mask)
ikind = int(kind, kind=c_int16_t)
ikind = iand(ikind, CFI_type_mask)
ikind = shiftl(ikind, CFI_type_kind_shift)
itype = ior(ikind, itype)
return
end function cfi_encode_type
end module isof_m
module iso_check_m
use, intrinsic :: iso_c_binding, only: &
c_signed_char, c_int16_t, c_size_t
use, intrinsic :: iso_c_binding, only: &
c_char
use :: isof_m, only: &
CFI_type_character
use :: isof_m, only: &
CFI_type_char, &
CFI_type_ucs4_char
use :: isof_m, only: &
check_tk_as, &
check_tk_ar
use :: isof_m, only: &
cfi_encode_type
implicit none
private
public :: &
check_c_char_l1, &
check_c_char_lm, &
check_c_ucs4_char_l1, &
check_c_ucs4_char_lm
integer :: i
integer(kind=c_size_t), parameter :: b = 8
integer, parameter :: n = 11
integer, parameter :: m = 7
integer, parameter :: c_ucs4_char = 4
character(kind=c_char, len=1), parameter :: ref_c_char_l1(*) = &
[(achar(i+iachar("A")-1, kind=c_char), i=1,n)]
character(kind=c_char, len=m), parameter :: ref_c_char_lm(*) = &
[(repeat(achar(i+iachar("A")-1, kind=c_char), m), i=1,n)]
character(kind=c_ucs4_char, len=1), parameter :: ref_c_ucs4_char_l1(*) = &
[(achar(i+iachar("A")-1, kind=c_ucs4_char), i=1,n)]
character(kind=c_ucs4_char, len=m), parameter :: ref_c_ucs4_char_lm(*) = &
[(repeat(achar(i+iachar("A")-1, kind=c_ucs4_char), m), i=1,n)]
contains
subroutine check_c_char_l1()
character(kind=c_char, len=1), target :: a(n)
!
character(kind=c_char, len=:), pointer :: p(:)
!
a = ref_c_char_l1
call f_check_c_char_c1_as(a)
if(any(a/=ref_c_char_l1)) stop 1
a = ref_c_char_l1
call c_check_c_char_c1_as(a)
if(any(a/=ref_c_char_l1)) stop 2
a = ref_c_char_l1
call f_check_c_char_c1_ar(a)
if(any(a/=ref_c_char_l1)) stop 3
a = ref_c_char_l1
call c_check_c_char_c1_ar(a)
if(any(a/=ref_c_char_l1)) stop 4
a = ref_c_char_l1
call f_check_c_char_a1_as(a)
if(any(a/=ref_c_char_l1)) stop 5
a = ref_c_char_l1
call c_check_c_char_a1_as(a)
if(any(a/=ref_c_char_l1)) stop 6
a = ref_c_char_l1
call f_check_c_char_a1_ar(a)
if(any(a/=ref_c_char_l1)) stop 7
a = ref_c_char_l1
call c_check_c_char_a1_ar(a)
if(any(a/=ref_c_char_l1)) stop 8
a = ref_c_char_l1
p => a
call f_check_c_char_d1_as(p)
if(.not.associated(p)) stop 9
if(.not.associated(p, a)) stop 10
if(any(p/=ref_c_char_l1)) stop 11
if(any(a/=ref_c_char_l1)) stop 12
a = ref_c_char_l1
p => a
call c_check_c_char_d1_as(p)
if(.not.associated(p)) stop 13
if(.not.associated(p, a)) stop 14
if(any(p/=ref_c_char_l1)) stop 15
if(any(a/=ref_c_char_l1)) stop 16
a = ref_c_char_l1
p => a
call f_check_c_char_d1_ar(p)
if(.not.associated(p)) stop 17
if(.not.associated(p, a)) stop 18
if(any(p/=ref_c_char_l1)) stop 19
if(any(a/=ref_c_char_l1)) stop 20
a = ref_c_char_l1
p => a
call c_check_c_char_d1_ar(p)
if(.not.associated(p)) stop 21
if(.not.associated(p, a)) stop 22
if(any(p/=ref_c_char_l1)) stop 23
if(any(a/=ref_c_char_l1)) stop 24
return
end subroutine check_c_char_l1
subroutine f_check_c_char_c1_as(a)
character(kind=c_char, len=1), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 25
if(k/=1_c_signed_char) stop 26
if(n/=1) stop 27
if(int(k, kind=c_size_t)/=e) stop 28
if(t/=CFI_type_char) stop 29
if(any(a/=ref_c_char_l1)) stop 30
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_char_l1)) stop 31
return
end subroutine f_check_c_char_c1_as
subroutine c_check_c_char_c1_as(a) bind(c)
character(kind=c_char, len=1), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 32
if(k/=1_c_signed_char) stop 33
if(n/=1) stop 34
if(int(k, kind=c_size_t)/=e) stop 35
if(t/=CFI_type_char) stop 36
if(any(a/=ref_c_char_l1)) stop 37
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_char_l1)) stop 38
return
end subroutine c_check_c_char_c1_as
subroutine f_check_c_char_c1_ar(a)
character(kind=c_char, len=1), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 39
if(k/=1_c_signed_char) stop 40
if(n/=1) stop 41
if(int(k, kind=c_size_t)/=e) stop 42
if(t/=CFI_type_char) stop 43
select rank(a)
rank(1)
if(any(a/=ref_c_char_l1)) stop 44
rank default
stop 45
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_char_l1)) stop 46
rank default
stop 47
end select
return
end subroutine f_check_c_char_c1_ar
subroutine c_check_c_char_c1_ar(a) bind(c)
character(kind=c_char, len=1), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 48
if(k/=1_c_signed_char) stop 49
if(n/=1) stop 50
if(int(k, kind=c_size_t)/=e) stop 51
if(t/=CFI_type_char) stop 52
select rank(a)
rank(1)
if(any(a/=ref_c_char_l1)) stop 53
rank default
stop 54
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_char_l1)) stop 55
rank default
stop 56
end select
return
end subroutine c_check_c_char_c1_ar
subroutine f_check_c_char_a1_as(a)
character(kind=c_char, len=*), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 57
if(k/=1_c_signed_char) stop 58
if(n/=1) stop 59
if(int(k, kind=c_size_t)/=e) stop 60
if(t/=CFI_type_char) stop 61
if(any(a/=ref_c_char_l1)) stop 62
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_char_l1)) stop 63
return
end subroutine f_check_c_char_a1_as
subroutine c_check_c_char_a1_as(a) bind(c)
character(kind=c_char, len=*), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 64
if(k/=1_c_signed_char) stop 65
if(n/=1) stop 66
if(int(k, kind=c_size_t)/=e) stop 67
if(t/=CFI_type_char) stop 68
if(any(a/=ref_c_char_l1)) stop 69
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_char_l1)) stop 70
return
end subroutine c_check_c_char_a1_as
subroutine f_check_c_char_a1_ar(a)
character(kind=c_char, len=*), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 71
if(k/=1_c_signed_char) stop 72
if(n/=1) stop 73
if(int(k, kind=c_size_t)/=e) stop 74
if(t/=CFI_type_char) stop 75
select rank(a)
rank(1)
if(any(a/=ref_c_char_l1)) stop 76
rank default
stop 77
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_char_l1)) stop 78
rank default
stop 79
end select
return
end subroutine f_check_c_char_a1_ar
subroutine c_check_c_char_a1_ar(a) bind(c)
character(kind=c_char, len=*), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 80
if(k/=1_c_signed_char) stop 81
if(n/=1) stop 82
if(int(k, kind=c_size_t)/=e) stop 83
if(t/=CFI_type_char) stop 84
select rank(a)
rank(1)
if(any(a/=ref_c_char_l1)) stop 85
rank default
stop 86
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_char_l1)) stop 87
rank default
stop 88
end select
return
end subroutine c_check_c_char_a1_ar
subroutine f_check_c_char_d1_as(a)
character(kind=c_char, len=:), pointer, intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 89
if(k/=1_c_signed_char) stop 90
if(n/=1) stop 91
if(int(k, kind=c_size_t)/=e) stop 92
if(t/=CFI_type_char) stop 93
if(any(a/=ref_c_char_l1)) stop 94
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_char_l1)) stop 95
return
end subroutine f_check_c_char_d1_as
subroutine c_check_c_char_d1_as(a) bind(c)
character(kind=c_char, len=:), pointer, intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 96
if(k/=1_c_signed_char) stop 97
if(n/=1) stop 98
if(int(k, kind=c_size_t)/=e) stop 99
if(t/=CFI_type_char) stop 100
if(any(a/=ref_c_char_l1)) stop 101
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_char_l1)) stop 102
return
end subroutine c_check_c_char_d1_as
subroutine f_check_c_char_d1_ar(a)
character(kind=c_char, len=:), pointer, intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 103
if(k/=1_c_signed_char) stop 104
if(n/=1) stop 105
if(int(k, kind=c_size_t)/=e) stop 106
if(t/=CFI_type_char) stop 107
select rank(a)
rank(1)
if(any(a/=ref_c_char_l1)) stop 108
rank default
stop 109
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_char_l1)) stop 110
rank default
stop 111
end select
return
end subroutine f_check_c_char_d1_ar
subroutine c_check_c_char_d1_ar(a) bind(c)
character(kind=c_char, len=:), pointer, intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 112
if(k/=1_c_signed_char) stop 113
if(n/=1) stop 114
if(int(k, kind=c_size_t)/=e) stop 115
if(t/=CFI_type_char) stop 116
select rank(a)
rank(1)
if(any(a/=ref_c_char_l1)) stop 117
rank default
stop 118
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_char_l1)) stop 119
rank default
stop 120
end select
return
end subroutine c_check_c_char_d1_ar
subroutine check_c_char_lm()
character(kind=c_char, len=m), target :: a(n)
!
character(kind=c_char, len=:), pointer :: p(:)
!
a = ref_c_char_lm
call f_check_c_char_cm_as(a)
if(any(a/=ref_c_char_lm)) stop 121
a = ref_c_char_lm
call c_check_c_char_cm_as(a)
if(any(a/=ref_c_char_lm)) stop 122
a = ref_c_char_lm
call f_check_c_char_cm_ar(a)
if(any(a/=ref_c_char_lm)) stop 123
a = ref_c_char_lm
call c_check_c_char_cm_ar(a)
if(any(a/=ref_c_char_lm)) stop 124
a = ref_c_char_lm
call f_check_c_char_am_as(a)
if(any(a/=ref_c_char_lm)) stop 125
a = ref_c_char_lm
call c_check_c_char_am_as(a)
if(any(a/=ref_c_char_lm)) stop 126
a = ref_c_char_lm
call f_check_c_char_am_ar(a)
if(any(a/=ref_c_char_lm)) stop 127
a = ref_c_char_lm
call c_check_c_char_am_ar(a)
if(any(a/=ref_c_char_lm)) stop 128
a = ref_c_char_lm
p => a
call f_check_c_char_dm_as(p)
if(.not.associated(p)) stop 129
if(.not.associated(p, a)) stop 130
if(any(p/=ref_c_char_lm)) stop 131
if(any(a/=ref_c_char_lm)) stop 132
a = ref_c_char_lm
p => a
call c_check_c_char_dm_as(p)
if(.not.associated(p)) stop 133
if(.not.associated(p, a)) stop 134
if(any(p/=ref_c_char_lm)) stop 135
if(any(a/=ref_c_char_lm)) stop 136
a = ref_c_char_lm
p => a
call f_check_c_char_dm_ar(p)
if(.not.associated(p)) stop 137
if(.not.associated(p, a)) stop 138
if(any(p/=ref_c_char_lm)) stop 139
if(any(a/=ref_c_char_lm)) stop 140
a = ref_c_char_lm
p => a
call c_check_c_char_dm_ar(p)
if(.not.associated(p)) stop 141
if(.not.associated(p, a)) stop 142
if(any(p/=ref_c_char_lm)) stop 143
if(any(a/=ref_c_char_lm)) stop 144
return
end subroutine check_c_char_lm
subroutine f_check_c_char_cm_as(a)
character(kind=c_char, len=m), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 145
if(k/=1_c_signed_char) stop 146
if(n/=m) stop 147
if(int(k, kind=c_size_t)/=e) stop 148
if(t/=CFI_type_char) stop 149
if(any(a/=ref_c_char_lm)) stop 150
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_char_lm)) stop 151
return
end subroutine f_check_c_char_cm_as
subroutine c_check_c_char_cm_as(a) bind(c)
character(kind=c_char, len=m), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 152
if(k/=1_c_signed_char) stop 153
if(n/=m) stop 154
if(int(k, kind=c_size_t)/=e) stop 155
if(t/=CFI_type_char) stop 156
if(any(a/=ref_c_char_lm)) stop 157
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_char_lm)) stop 158
return
end subroutine c_check_c_char_cm_as
subroutine f_check_c_char_cm_ar(a)
character(kind=c_char, len=m), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 159
if(k/=1_c_signed_char) stop 160
if(n/=m) stop 161
if(int(k, kind=c_size_t)/=e) stop 162
if(t/=CFI_type_char) stop 163
select rank(a)
rank(1)
if(any(a/=ref_c_char_lm)) stop 164
rank default
stop 165
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_char_lm)) stop 166
rank default
stop 167
end select
return
end subroutine f_check_c_char_cm_ar
subroutine c_check_c_char_cm_ar(a) bind(c)
character(kind=c_char, len=m), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 168
if(k/=1_c_signed_char) stop 169
if(n/=m) stop 170
if(int(k, kind=c_size_t)/=e) stop 171
if(t/=CFI_type_char) stop 172
select rank(a)
rank(1)
if(any(a/=ref_c_char_lm)) stop 173
rank default
stop 174
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_char_lm)) stop 175
rank default
stop 176
end select
return
end subroutine c_check_c_char_cm_ar
subroutine f_check_c_char_am_as(a)
character(kind=c_char, len=*), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 177
if(k/=1_c_signed_char) stop 178
if(n/=m) stop 179
if(int(k, kind=c_size_t)/=e) stop 180
if(t/=CFI_type_char) stop 181
if(any(a/=ref_c_char_lm)) stop 182
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_char_lm)) stop 183
return
end subroutine f_check_c_char_am_as
subroutine c_check_c_char_am_as(a) bind(c)
character(kind=c_char, len=*), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 184
if(k/=1_c_signed_char) stop 185
if(n/=m) stop 186
if(int(k, kind=c_size_t)/=e) stop 187
if(t/=CFI_type_char) stop 188
if(any(a/=ref_c_char_lm)) stop 189
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_char_lm)) stop 190
return
end subroutine c_check_c_char_am_as
subroutine f_check_c_char_am_ar(a)
character(kind=c_char, len=*), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 191
if(k/=1_c_signed_char) stop 192
if(n/=m) stop 193
if(int(k, kind=c_size_t)/=e) stop 194
if(t/=CFI_type_char) stop 195
select rank(a)
rank(1)
if(any(a/=ref_c_char_lm)) stop 196
rank default
stop 197
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_char_lm)) stop 198
rank default
stop 199
end select
return
end subroutine f_check_c_char_am_ar
subroutine c_check_c_char_am_ar(a) bind(c)
character(kind=c_char, len=*), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 200
if(k/=1_c_signed_char) stop 201
if(n/=m) stop 202
if(int(k, kind=c_size_t)/=e) stop 203
if(t/=CFI_type_char) stop 204
select rank(a)
rank(1)
if(any(a/=ref_c_char_lm)) stop 205
rank default
stop 206
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_char_lm)) stop 207
rank default
stop 208
end select
return
end subroutine c_check_c_char_am_ar
subroutine f_check_c_char_dm_as(a)
character(kind=c_char, len=:), pointer, intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 209
if(k/=1_c_signed_char) stop 210
if(n/=m) stop 211
if(int(k, kind=c_size_t)/=e) stop 212
if(t/=CFI_type_char) stop 213
if(any(a/=ref_c_char_lm)) stop 214
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_char_lm)) stop 215
return
end subroutine f_check_c_char_dm_as
subroutine c_check_c_char_dm_as(a) bind(c)
character(kind=c_char, len=:), pointer, intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 216
if(k/=1_c_signed_char) stop 217
if(n/=m) stop 218
if(int(k, kind=c_size_t)/=e) stop 219
if(t/=CFI_type_char) stop 220
if(any(a/=ref_c_char_lm)) stop 221
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_char_lm)) stop 222
return
end subroutine c_check_c_char_dm_as
subroutine f_check_c_char_dm_ar(a)
character(kind=c_char, len=:), pointer, intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 223
if(k/=1_c_signed_char) stop 224
if(n/=m) stop 225
if(int(k, kind=c_size_t)/=e) stop 226
if(t/=CFI_type_char) stop 227
select rank(a)
rank(1)
if(any(a/=ref_c_char_lm)) stop 228
rank default
stop 229
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_char_lm)) stop 230
rank default
stop 231
end select
return
end subroutine f_check_c_char_dm_ar
subroutine c_check_c_char_dm_ar(a) bind(c)
character(kind=c_char, len=:), pointer, intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 232
if(k/=1_c_signed_char) stop 233
if(n/=m) stop 234
if(int(k, kind=c_size_t)/=e) stop 235
if(t/=CFI_type_char) stop 236
select rank(a)
rank(1)
if(any(a/=ref_c_char_lm)) stop 237
rank default
stop 238
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_char_lm)) stop 239
rank default
stop 240
end select
return
end subroutine c_check_c_char_dm_ar
subroutine check_c_ucs4_char_l1()
character(kind=c_ucs4_char, len=1), target :: a(n)
!
character(kind=c_ucs4_char, len=:), pointer :: p(:)
!
a = ref_c_ucs4_char_l1
call f_check_c_ucs4_char_c1_as(a)
if(any(a/=ref_c_ucs4_char_l1)) stop 241
a = ref_c_ucs4_char_l1
call c_check_c_ucs4_char_c1_as(a)
if(any(a/=ref_c_ucs4_char_l1)) stop 242
a = ref_c_ucs4_char_l1
call f_check_c_ucs4_char_c1_ar(a)
if(any(a/=ref_c_ucs4_char_l1)) stop 243
a = ref_c_ucs4_char_l1
call c_check_c_ucs4_char_c1_ar(a)
if(any(a/=ref_c_ucs4_char_l1)) stop 244
a = ref_c_ucs4_char_l1
call f_check_c_ucs4_char_a1_as(a)
if(any(a/=ref_c_ucs4_char_l1)) stop 245
a = ref_c_ucs4_char_l1
call c_check_c_ucs4_char_a1_as(a)
if(any(a/=ref_c_ucs4_char_l1)) stop 246
a = ref_c_ucs4_char_l1
call f_check_c_ucs4_char_a1_ar(a)
if(any(a/=ref_c_ucs4_char_l1)) stop 247
a = ref_c_ucs4_char_l1
call c_check_c_ucs4_char_a1_ar(a)
if(any(a/=ref_c_ucs4_char_l1)) stop 248
a = ref_c_ucs4_char_l1
p => a
call f_check_c_ucs4_char_d1_as(p)
if(.not.associated(p)) stop 249
if(.not.associated(p, a)) stop 250
if(any(p/=ref_c_ucs4_char_l1)) stop 251
if(any(a/=ref_c_ucs4_char_l1)) stop 252
a = ref_c_ucs4_char_l1
p => a
call c_check_c_ucs4_char_d1_as(p)
if(.not.associated(p)) stop 253
if(.not.associated(p, a)) stop 254
if(any(p/=ref_c_ucs4_char_l1)) stop 255
if(any(a/=ref_c_ucs4_char_l1)) stop 256
a = ref_c_ucs4_char_l1
p => a
call f_check_c_ucs4_char_d1_ar(p)
if(.not.associated(p)) stop 257
if(.not.associated(p, a)) stop 258
if(any(p/=ref_c_ucs4_char_l1)) stop 259
if(any(a/=ref_c_ucs4_char_l1)) stop 260
a = ref_c_ucs4_char_l1
p => a
call c_check_c_ucs4_char_d1_ar(p)
if(.not.associated(p)) stop 261
if(.not.associated(p, a)) stop 262
if(any(p/=ref_c_ucs4_char_l1)) stop 263
if(any(a/=ref_c_ucs4_char_l1)) stop 264
return
end subroutine check_c_ucs4_char_l1
subroutine f_check_c_ucs4_char_c1_as(a)
character(kind=c_ucs4_char, len=1), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 265
if(k/=4_c_signed_char) stop 266
if(n/=1) stop 267
if(int(k, kind=c_size_t)/=e) stop 268
if(t/=CFI_type_ucs4_char) stop 269
if(any(a/=ref_c_ucs4_char_l1)) stop 270
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_ucs4_char_l1)) stop 271
return
end subroutine f_check_c_ucs4_char_c1_as
subroutine c_check_c_ucs4_char_c1_as(a) bind(c)
character(kind=c_ucs4_char, len=1), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 272
if(k/=4_c_signed_char) stop 273
if(n/=1) stop 274
if(int(k, kind=c_size_t)/=e) stop 275
if(t/=CFI_type_ucs4_char) stop 276
if(any(a/=ref_c_ucs4_char_l1)) stop 277
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_ucs4_char_l1)) stop 278
return
end subroutine c_check_c_ucs4_char_c1_as
subroutine f_check_c_ucs4_char_c1_ar(a)
character(kind=c_ucs4_char, len=1), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 279
if(k/=4_c_signed_char) stop 280
if(n/=1) stop 281
if(int(k, kind=c_size_t)/=e) stop 282
if(t/=CFI_type_ucs4_char) stop 283
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_l1)) stop 284
rank default
stop 285
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_l1)) stop 286
rank default
stop 287
end select
return
end subroutine f_check_c_ucs4_char_c1_ar
subroutine c_check_c_ucs4_char_c1_ar(a) bind(c)
character(kind=c_ucs4_char, len=1), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 288
if(k/=4_c_signed_char) stop 289
if(n/=1) stop 290
if(int(k, kind=c_size_t)/=e) stop 291
if(t/=CFI_type_ucs4_char) stop 292
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_l1)) stop 293
rank default
stop 294
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_l1)) stop 295
rank default
stop 296
end select
return
end subroutine c_check_c_ucs4_char_c1_ar
subroutine f_check_c_ucs4_char_a1_as(a)
character(kind=c_ucs4_char, len=*), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 297
if(k/=4_c_signed_char) stop 298
if(n/=1) stop 299
if(int(k, kind=c_size_t)/=e) stop 300
if(t/=CFI_type_ucs4_char) stop 301
if(any(a/=ref_c_ucs4_char_l1)) stop 302
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_ucs4_char_l1)) stop 303
return
end subroutine f_check_c_ucs4_char_a1_as
subroutine c_check_c_ucs4_char_a1_as(a) bind(c)
character(kind=c_ucs4_char, len=*), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 304
if(k/=4_c_signed_char) stop 305
if(n/=1) stop 306
if(int(k, kind=c_size_t)/=e) stop 307
if(t/=CFI_type_ucs4_char) stop 308
if(any(a/=ref_c_ucs4_char_l1)) stop 309
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_ucs4_char_l1)) stop 310
return
end subroutine c_check_c_ucs4_char_a1_as
subroutine f_check_c_ucs4_char_a1_ar(a)
character(kind=c_ucs4_char, len=*), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 311
if(k/=4_c_signed_char) stop 312
if(n/=1) stop 313
if(int(k, kind=c_size_t)/=e) stop 314
if(t/=CFI_type_ucs4_char) stop 315
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_l1)) stop 316
rank default
stop 317
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_l1)) stop 318
rank default
stop 319
end select
return
end subroutine f_check_c_ucs4_char_a1_ar
subroutine c_check_c_ucs4_char_a1_ar(a) bind(c)
character(kind=c_ucs4_char, len=*), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 320
if(k/=4_c_signed_char) stop 321
if(n/=1) stop 322
if(int(k, kind=c_size_t)/=e) stop 323
if(t/=CFI_type_ucs4_char) stop 324
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_l1)) stop 325
rank default
stop 326
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_l1)) stop 327
rank default
stop 328
end select
return
end subroutine c_check_c_ucs4_char_a1_ar
subroutine f_check_c_ucs4_char_d1_as(a)
character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 329
if(k/=4_c_signed_char) stop 330
if(n/=1) stop 331
if(int(k, kind=c_size_t)/=e) stop 332
if(t/=CFI_type_ucs4_char) stop 333
if(any(a/=ref_c_ucs4_char_l1)) stop 334
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_ucs4_char_l1)) stop 335
return
end subroutine f_check_c_ucs4_char_d1_as
subroutine c_check_c_ucs4_char_d1_as(a) bind(c)
character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 336
if(k/=4_c_signed_char) stop 337
if(n/=1) stop 338
if(int(k, kind=c_size_t)/=e) stop 339
if(t/=CFI_type_ucs4_char) stop 340
if(any(a/=ref_c_ucs4_char_l1)) stop 341
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_ucs4_char_l1)) stop 342
return
end subroutine c_check_c_ucs4_char_d1_as
subroutine f_check_c_ucs4_char_d1_ar(a)
character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 343
if(k/=4_c_signed_char) stop 344
if(n/=1) stop 345
if(int(k, kind=c_size_t)/=e) stop 346
if(t/=CFI_type_ucs4_char) stop 347
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_l1)) stop 348
rank default
stop 349
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_l1)) stop 350
rank default
stop 351
end select
return
end subroutine f_check_c_ucs4_char_d1_ar
subroutine c_check_c_ucs4_char_d1_ar(a) bind(c)
character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*1)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 352
if(k/=4_c_signed_char) stop 353
if(n/=1) stop 354
if(int(k, kind=c_size_t)/=e) stop 355
if(t/=CFI_type_ucs4_char) stop 356
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_l1)) stop 357
rank default
stop 358
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_l1)) stop 359
rank default
stop 360
end select
return
end subroutine c_check_c_ucs4_char_d1_ar
subroutine check_c_ucs4_char_lm()
character(kind=c_ucs4_char, len=m), target :: a(n)
!
character(kind=c_ucs4_char, len=:), pointer :: p(:)
!
a = ref_c_ucs4_char_lm
call f_check_c_ucs4_char_cm_as(a)
if(any(a/=ref_c_ucs4_char_lm)) stop 361
a = ref_c_ucs4_char_lm
call c_check_c_ucs4_char_cm_as(a)
if(any(a/=ref_c_ucs4_char_lm)) stop 362
a = ref_c_ucs4_char_lm
call f_check_c_ucs4_char_cm_ar(a)
if(any(a/=ref_c_ucs4_char_lm)) stop 363
a = ref_c_ucs4_char_lm
call c_check_c_ucs4_char_cm_ar(a)
if(any(a/=ref_c_ucs4_char_lm)) stop 364
a = ref_c_ucs4_char_lm
call f_check_c_ucs4_char_am_as(a)
if(any(a/=ref_c_ucs4_char_lm)) stop 365
a = ref_c_ucs4_char_lm
call c_check_c_ucs4_char_am_as(a)
if(any(a/=ref_c_ucs4_char_lm)) stop 366
a = ref_c_ucs4_char_lm
call f_check_c_ucs4_char_am_ar(a)
if(any(a/=ref_c_ucs4_char_lm)) stop 367
a = ref_c_ucs4_char_lm
call c_check_c_ucs4_char_am_ar(a)
if(any(a/=ref_c_ucs4_char_lm)) stop 368
a = ref_c_ucs4_char_lm
p => a
call f_check_c_ucs4_char_dm_as(p)
if(.not.associated(p)) stop 369
if(.not.associated(p, a)) stop 370
if(any(p/=ref_c_ucs4_char_lm)) stop 371
if(any(a/=ref_c_ucs4_char_lm)) stop 372
a = ref_c_ucs4_char_lm
p => a
call c_check_c_ucs4_char_dm_as(p)
if(.not.associated(p)) stop 373
if(.not.associated(p, a)) stop 374
if(any(p/=ref_c_ucs4_char_lm)) stop 375
if(any(a/=ref_c_ucs4_char_lm)) stop 376
a = ref_c_ucs4_char_lm
p => a
call f_check_c_ucs4_char_dm_ar(p)
if(.not.associated(p)) stop 377
if(.not.associated(p, a)) stop 378
if(any(p/=ref_c_ucs4_char_lm)) stop 379
if(any(a/=ref_c_ucs4_char_lm)) stop 380
a = ref_c_ucs4_char_lm
p => a
call c_check_c_ucs4_char_dm_ar(p)
if(.not.associated(p)) stop 381
if(.not.associated(p, a)) stop 382
if(any(p/=ref_c_ucs4_char_lm)) stop 383
if(any(a/=ref_c_ucs4_char_lm)) stop 384
return
end subroutine check_c_ucs4_char_lm
subroutine f_check_c_ucs4_char_cm_as(a)
character(kind=c_ucs4_char, len=m), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 385
if(k/=4_c_signed_char) stop 386
if(n/=m) stop 387
if(int(k, kind=c_size_t)/=e) stop 388
if(t/=CFI_type_ucs4_char) stop 389
if(any(a/=ref_c_ucs4_char_lm)) stop 390
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_ucs4_char_lm)) stop 391
return
end subroutine f_check_c_ucs4_char_cm_as
subroutine c_check_c_ucs4_char_cm_as(a) bind(c)
character(kind=c_ucs4_char, len=m), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 392
if(k/=4_c_signed_char) stop 393
if(n/=m) stop 394
if(int(k, kind=c_size_t)/=e) stop 395
if(t/=CFI_type_ucs4_char) stop 396
if(any(a/=ref_c_ucs4_char_lm)) stop 397
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_ucs4_char_lm)) stop 398
return
end subroutine c_check_c_ucs4_char_cm_as
subroutine f_check_c_ucs4_char_cm_ar(a)
character(kind=c_ucs4_char, len=m), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 399
if(k/=4_c_signed_char) stop 400
if(n/=m) stop 401
if(int(k, kind=c_size_t)/=e) stop 402
if(t/=CFI_type_ucs4_char) stop 403
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_lm)) stop 404
rank default
stop 405
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_lm)) stop 406
rank default
stop 407
end select
return
end subroutine f_check_c_ucs4_char_cm_ar
subroutine c_check_c_ucs4_char_cm_ar(a) bind(c)
character(kind=c_ucs4_char, len=m), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 408
if(k/=4_c_signed_char) stop 409
if(n/=m) stop 410
if(int(k, kind=c_size_t)/=e) stop 411
if(t/=CFI_type_ucs4_char) stop 412
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_lm)) stop 413
rank default
stop 414
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_lm)) stop 415
rank default
stop 416
end select
return
end subroutine c_check_c_ucs4_char_cm_ar
subroutine f_check_c_ucs4_char_am_as(a)
character(kind=c_ucs4_char, len=*), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 417
if(k/=4_c_signed_char) stop 418
if(n/=m) stop 419
if(int(k, kind=c_size_t)/=e) stop 420
if(t/=CFI_type_ucs4_char) stop 421
if(any(a/=ref_c_ucs4_char_lm)) stop 422
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_ucs4_char_lm)) stop 423
return
end subroutine f_check_c_ucs4_char_am_as
subroutine c_check_c_ucs4_char_am_as(a) bind(c)
character(kind=c_ucs4_char, len=*), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 424
if(k/=4_c_signed_char) stop 425
if(n/=m) stop 426
if(int(k, kind=c_size_t)/=e) stop 427
if(t/=CFI_type_ucs4_char) stop 428
if(any(a/=ref_c_ucs4_char_lm)) stop 429
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_ucs4_char_lm)) stop 430
return
end subroutine c_check_c_ucs4_char_am_as
subroutine f_check_c_ucs4_char_am_ar(a)
character(kind=c_ucs4_char, len=*), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 431
if(k/=4_c_signed_char) stop 432
if(n/=m) stop 433
if(int(k, kind=c_size_t)/=e) stop 434
if(t/=CFI_type_ucs4_char) stop 435
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_lm)) stop 436
rank default
stop 437
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_lm)) stop 438
rank default
stop 439
end select
return
end subroutine f_check_c_ucs4_char_am_ar
subroutine c_check_c_ucs4_char_am_ar(a) bind(c)
character(kind=c_ucs4_char, len=*), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 440
if(k/=4_c_signed_char) stop 441
if(n/=m) stop 442
if(int(k, kind=c_size_t)/=e) stop 443
if(t/=CFI_type_ucs4_char) stop 444
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_lm)) stop 445
rank default
stop 446
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_lm)) stop 447
rank default
stop 448
end select
return
end subroutine c_check_c_ucs4_char_am_ar
subroutine f_check_c_ucs4_char_dm_as(a)
character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 449
if(k/=4_c_signed_char) stop 450
if(n/=m) stop 451
if(int(k, kind=c_size_t)/=e) stop 452
if(t/=CFI_type_ucs4_char) stop 453
if(any(a/=ref_c_ucs4_char_lm)) stop 454
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_ucs4_char_lm)) stop 455
return
end subroutine f_check_c_ucs4_char_dm_as
subroutine c_check_c_ucs4_char_dm_as(a) bind(c)
character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 456
if(k/=4_c_signed_char) stop 457
if(n/=m) stop 458
if(int(k, kind=c_size_t)/=e) stop 459
if(t/=CFI_type_ucs4_char) stop 460
if(any(a/=ref_c_ucs4_char_lm)) stop 461
call check_tk_as(a, t, k, e, n)
if(any(a/=ref_c_ucs4_char_lm)) stop 462
return
end subroutine c_check_c_ucs4_char_dm_as
subroutine f_check_c_ucs4_char_dm_ar(a)
character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 463
if(k/=4_c_signed_char) stop 464
if(n/=m) stop 465
if(int(k, kind=c_size_t)/=e) stop 466
if(t/=CFI_type_ucs4_char) stop 467
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_lm)) stop 468
rank default
stop 469
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_lm)) stop 470
rank default
stop 471
end select
return
end subroutine f_check_c_ucs4_char_dm_ar
subroutine c_check_c_ucs4_char_dm_ar(a) bind(c)
character(kind=c_ucs4_char, len=:), pointer, intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e, n
!
k = kind(a)
n = len(a, kind=kind(e))
e = storage_size(a, kind=kind(e))/(b*m)
t = cfi_encode_type(CFI_type_Character, k)
if(k<=0_c_signed_char) stop 472
if(k/=4_c_signed_char) stop 473
if(n/=m) stop 474
if(int(k, kind=c_size_t)/=e) stop 475
if(t/=CFI_type_ucs4_char) stop 476
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_lm)) stop 477
rank default
stop 478
end select
call check_tk_ar(a, t, k, e, n)
select rank(a)
rank(1)
if(any(a/=ref_c_ucs4_char_lm)) stop 479
rank default
stop 480
end select
return
end subroutine c_check_c_ucs4_char_dm_ar
end module iso_check_m
program main_p
use :: iso_check_m, only: &
check_c_char_l1, &
check_c_char_lm, &
check_c_ucs4_char_l1, &
check_c_ucs4_char_lm
implicit none
call check_c_char_l1()
call check_c_char_lm()
! See PR100907
!call check_c_ucs4_char_l1()
!call check_c_ucs4_char_lm()
stop
end program main_p
!! Local Variables:
!! mode: f90
!! End:

Fortran/gfortran/regression/PR100911.c

/* Test the fix for PR100911 */
#include <assert.h>
#include <stdbool.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#define _CFI_type_mask 0xFF
#define _CFI_type_kind_shift 8
#define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask)
#define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask)
#define _CFI_encode_type(TYPE, KIND) (int16_t)\
((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\
| ((TYPE) & CFI_type_mask))
#define N 11
#define M 7
#define CFI_type_Cptr CFI_type_cptr
typedef int* c_ptr;
bool c_vrfy_cptr (const CFI_cdesc_t *restrict);
void check_tk (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t);
bool
c_vrfy_cptr (const CFI_cdesc_t *restrict auxp)
{
CFI_index_t i, lb, ub, ex;
size_t sz;
c_ptr *ip = NULL;
assert (auxp);
assert (auxp->base_addr);
assert (auxp->elem_len>0);
lb = auxp->dim[0].lower_bound;
ex = auxp->dim[0].extent;
assert (ex==11);
sz = (size_t)auxp->elem_len / sizeof (c_ptr);
assert (sz==1);
ub = ex + lb - 1;
ip = (c_ptr*)auxp->base_addr;
for (i=0; i<ex; i++, ip+=sz)
if ((**ip) != (int)(i+1))
return false;
for (i=lb; i<ub+1; i++)
{
ip = (c_ptr*)CFI_address(auxp, &i);
if ((**ip) != (int)(i-lb+1))
return false;
}
return true;
}
void
check_tk (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed char kind, const size_t elem_len, const size_t nelem)
{
signed char ityp, iknd;
assert (auxp);
assert (auxp->elem_len==elem_len*nelem);
assert (auxp->rank==1);
assert (auxp->dim[0].sm>0);
assert ((size_t)auxp->dim[0].sm==elem_len*nelem);
/* */
assert (auxp->type==type);
ityp = _CFI_decode_type(auxp->type);
assert (ityp == CFI_type_cptr);
iknd = _CFI_decode_kind(auxp->type);
assert (_CFI_decode_type(type)==ityp);
assert (kind==iknd);
assert (c_vrfy_cptr (auxp));
return;
}
// Local Variables:
// mode: C
// End:

Fortran/gfortran/regression/PR100911.f90

! { dg-do run }
! { dg-additional-sources PR100911.c }
!
! Test the fix for PR100911
!
module isof_m
use, intrinsic :: iso_c_binding, only: &
c_signed_char, c_int16_t
implicit none
private
public :: &
CFI_type_cptr
public :: &
check_tk_as, &
check_tk_ar
public :: &
cfi_encode_type
integer, parameter :: CFI_type_t = c_int16_t
integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t)
integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t
! Intrinsic types. Their kind number defines their storage size. */
integer(kind=c_signed_char), parameter :: CFI_type_cptr = 7
interface
subroutine check_tk_as(a, t, k, e, n) &
bind(c, name="check_tk")
use, intrinsic :: iso_c_binding, only: &
c_int16_t, c_signed_char, c_size_t
implicit none
type(*), intent(in) :: a(:)
integer(c_int16_t), value, intent(in) :: t
integer(c_signed_char), value, intent(in) :: k
integer(c_size_t), value, intent(in) :: e
integer(c_size_t), value, intent(in) :: n
end subroutine check_tk_as
subroutine check_tk_ar(a, t, k, e, n) &
bind(c, name="check_tk")
use, intrinsic :: iso_c_binding, only: &
c_int16_t, c_signed_char, c_size_t
implicit none
type(*), intent(in) :: a(..)
integer(c_int16_t), value, intent(in) :: t
integer(c_signed_char), value, intent(in) :: k
integer(c_size_t), value, intent(in) :: e
integer(c_size_t), value, intent(in) :: n
end subroutine check_tk_ar
end interface
contains
elemental function cfi_encode_type(type, kind) result(itype)
integer(kind=c_signed_char), intent(in) :: type
integer(kind=c_signed_char), intent(in) :: kind
integer(kind=c_int16_t) :: itype, ikind
itype = int(type, kind=c_int16_t)
itype = iand(itype, CFI_type_mask)
ikind = int(kind, kind=c_int16_t)
ikind = iand(ikind, CFI_type_mask)
ikind = shiftl(ikind, CFI_type_kind_shift)
itype = ior(ikind, itype)
return
end function cfi_encode_type
end module isof_m
module iso_check_m
use, intrinsic :: iso_c_binding, only: &
c_signed_char, c_int16_t, c_size_t
use, intrinsic :: iso_c_binding, only: &
c_int, c_ptr, c_loc, c_associated
use, intrinsic :: iso_c_binding, only: &
c_ptr
use :: isof_m, only: &
CFI_type_cptr
use :: isof_m, only: &
check_tk_as, &
check_tk_ar
use :: isof_m, only: &
cfi_encode_type
implicit none
integer :: i
integer(kind=c_size_t), parameter :: b = 8
integer, parameter :: n = 11
type, bind(c) :: c_foo_t
integer(kind=c_int) :: a
end type c_foo_t
type(c_foo_t), parameter :: ref_c_foo_t(*) = [(c_foo_t(a=i), i=1,n)]
type(c_foo_t), protected, target :: target_c_foo_t(n)
contains
subroutine check_c_ptr()
type(c_ptr) :: p(n)
integer :: i
!
target_c_foo_t = ref_c_foo_t
p = [(c_loc(target_c_foo_t(i)), i=1,n)]
call f_check_c_ptr_as(p)
if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 1
do i = 1, n
if(.not.c_associated(p(i), c_loc(target_c_foo_t(i)))) stop 2
end do
target_c_foo_t = ref_c_foo_t
p = [(c_loc(target_c_foo_t(i)), i=1,n)]
call c_check_c_ptr_as(p)
if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 3
do i = 1, n
if(.not.c_associated(p(i), c_loc(target_c_foo_t(i)))) stop 4
end do
target_c_foo_t = ref_c_foo_t
p = [(c_loc(target_c_foo_t(i)), i=1,n)]
call f_check_c_ptr_ar(p)
if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 5
do i = 1, n
if(.not.c_associated(p(i), c_loc(target_c_foo_t(i)))) stop 6
end do
target_c_foo_t = ref_c_foo_t
p = [(c_loc(target_c_foo_t(i)), i=1,n)]
call c_check_c_ptr_ar(p)
if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 7
do i = 1, n
if(.not.c_associated(p(i), c_loc(target_c_foo_t(i)))) stop 8
end do
return
end subroutine check_c_ptr
subroutine f_check_c_ptr_as(a)
type(c_ptr), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = 0
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_cptr, k)
! Assumes 64-bit target.
! if(e/=8) stop 9
if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 10
do i = 1, n
if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 11
end do
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 12
do i = 1, n
if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 13
end do
return
end subroutine f_check_c_ptr_as
subroutine c_check_c_ptr_as(a) bind(c)
type(c_ptr), intent(in) :: a(:)
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = 0
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_cptr, k)
! Assumes 64-bit target.
! if(e/=8) stop 14
if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 15
do i = 1, n
if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 16
end do
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 17
do i = 1, n
if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 18
end do
return
end subroutine c_check_c_ptr_as
subroutine f_check_c_ptr_ar(a)
type(c_ptr), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = 0
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_cptr, k)
! Assumes 64-bit target.
! if(e/=8) stop 19
select rank(a)
rank(1)
if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 20
do i = 1, n
if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 21
end do
rank default
stop 22
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 23
do i = 1, n
if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 24
end do
rank default
stop 25
end select
return
end subroutine f_check_c_ptr_ar
subroutine c_check_c_ptr_ar(a) bind(c)
type(c_ptr), intent(in) :: a(..)
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = 0
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_cptr, k)
! Assumes 64-bit target.
! if(e/=8) stop 26
select rank(a)
rank(1)
if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 27
do i = 1, n
if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 28
end do
rank default
stop 29
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(target_c_foo_t(:)%a/=ref_c_foo_t(:)%a)) stop 30
do i = 1, n
if(.not.c_associated(a(i), c_loc(target_c_foo_t(i)))) stop 31
end do
rank default
stop 32
end select
return
end subroutine c_check_c_ptr_ar
end module iso_check_m
program main_p
use :: iso_check_m, only: &
check_c_ptr
implicit none
call check_c_ptr()
stop
end program main_p
!! Local Variables:
!! mode: f90
!! End:

Fortran/gfortran/regression/PR100914.c

/* Test the fix for PR100914 */
#include <assert.h>
#include <complex.h>
#include <stdbool.h>
#include <stdio.h>
#include <math.h>
#include <ISO_Fortran_binding.h>
#define _CFI_type_mask 0xFF
#define _CFI_type_kind_shift 8
#define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask)
#define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask)
#define _CFI_encode_type(TYPE, KIND) (int16_t)\
((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\
| ((TYPE) & CFI_type_mask))
#undef CMPLXF
#define CMPLXF(x, y) ((float complex)((float)(x) + I * (float)(y)))
#undef CMPLX
#define CMPLX(x, y) ((double complex)((double)(x) + (double complex)I * (double)(y)))
#undef CMPLXL
#define CMPLXL(x, y) ((long double complex)((long double)(x) + (long double complex)I * (long double)(y)))
#undef CMPLX
#define CMPLX(x, y) ((_Float128 _Complex )((double)(x) + (double complex)I * (double)(y)))
#define N 11
#define M 7
typedef float _Complex c_float_complex;
typedef double _Complex c_double_complex;
typedef long double _Complex c_long_double_complex;
typedef _Float128 _Complex c_float128_complex;
bool c_vrfy_c_float_complex (const CFI_cdesc_t *restrict);
bool c_vrfy_c_double_complex (const CFI_cdesc_t *restrict);
bool c_vrfy_c_long_double_complex (const CFI_cdesc_t *restrict);
bool c_vrfy_c_float128_complex (const CFI_cdesc_t *restrict);
bool c_vrfy_complex (const CFI_cdesc_t *restrict);
bool c_vrfy_desc (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t);
void check_tk (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t);
bool
c_vrfy_c_float_complex (const CFI_cdesc_t *restrict auxp)
{
CFI_index_t i, lb, ub, ex;
size_t sz;
c_float_complex *ip = NULL;
assert (auxp);
assert (auxp->base_addr);
assert (auxp->elem_len>0);
lb = auxp->dim[0].lower_bound;
ex = auxp->dim[0].extent;
assert (ex==11);
sz = (size_t)auxp->elem_len / sizeof (c_float_complex);
assert (sz==1);
ub = ex + lb - 1;
ip = (c_float_complex*)auxp->base_addr;
for (i=0; i<ex; i++, ip+=sz)
if ((cabsf (*ip-(c_float_complex)(CMPLXF((i+1), (2*(i+1)))))>(float)0.0))
return false;
for (i=lb; i<ub+1; i++)
{
ip = (c_float_complex*)CFI_address(auxp, &i);
if ((cabsf (*ip-(c_float_complex)(CMPLXF((i-lb+1), (2*(i-lb+1)))))>(float)0.0))
return false;
}
return true;
}
bool
c_vrfy_c_double_complex (const CFI_cdesc_t *restrict auxp)
{
CFI_index_t i, lb, ub, ex;
size_t sz;
c_double_complex *ip = NULL;
assert (auxp);
assert (auxp->base_addr);
assert (auxp->elem_len>0);
lb = auxp->dim[0].lower_bound;
ex = auxp->dim[0].extent;
assert (ex==11);
sz = (size_t)auxp->elem_len / sizeof (c_double_complex);
assert (sz==1);
ub = ex + lb - 1;
ip = (c_double_complex*)auxp->base_addr;
for (i=0; i<ex; i++, ip+=sz)
if ((cabs (*ip-(c_double_complex)(CMPLX((i+1), (2*(i+1)))))>(double)0.0))
return false;
for (i=lb; i<ub+1; i++)
{
ip = (c_double_complex*)CFI_address(auxp, &i);
if ((cabs (*ip-(c_double_complex)(CMPLX((i-lb+1), (2*(i-lb+1)))))>(double)0.0))
return false;
}
return true;
}
bool
c_vrfy_c_long_double_complex (const CFI_cdesc_t *restrict auxp)
{
CFI_index_t i, lb, ub, ex;
size_t sz;
c_long_double_complex *ip = NULL;
assert (auxp);
assert (auxp->base_addr);
assert (auxp->elem_len>0);
lb = auxp->dim[0].lower_bound;
ex = auxp->dim[0].extent;
assert (ex==11);
sz = (size_t)auxp->elem_len / sizeof (c_long_double_complex);
assert (sz==1);
ub = ex + lb - 1;
ip = (c_long_double_complex*)auxp->base_addr;
for (i=0; i<ex; i++, ip+=sz)
if ((cabsl (*ip-(c_long_double_complex)(CMPLXL((i+1), (2*(i+1)))))>(long double)0.0))
return false;
for (i=lb; i<ub+1; i++)
{
ip = (c_long_double_complex*)CFI_address(auxp, &i);
if ((cabsl (*ip-(c_long_double_complex)(CMPLXL((i-lb+1), (2*(i-lb+1)))))>(long double)0.0))
return false;
}
return true;
}
bool
c_vrfy_c_float128_complex (const CFI_cdesc_t *restrict auxp)
{
CFI_index_t i, lb, ub, ex;
size_t sz;
c_float128_complex *ip = NULL;
assert (auxp);
assert (auxp->base_addr);
assert (auxp->elem_len>0);
lb = auxp->dim[0].lower_bound;
ex = auxp->dim[0].extent;
assert (ex==11);
sz = (size_t)auxp->elem_len / sizeof (c_float128_complex);
assert (sz==1);
ub = ex + lb - 1;
ip = (c_float128_complex*)auxp->base_addr;
for (i=0; i<ex; i++, ip+=sz)
if ((cabs ((double complex)(*ip-(c_float128_complex)(CMPLX((i+1), (2*(i+1))))))>(double)0.0))
return false;
for (i=lb; i<ub+1; i++)
{
ip = (c_float128_complex*)CFI_address(auxp, &i);
if ((cabs ((double complex)(*ip-(c_float128_complex)(CMPLX((i-lb+1), (2*(i-lb+1))))))>(double)0.0))
return false;
}
return true;
}
bool
c_vrfy_complex (const CFI_cdesc_t *restrict auxp)
{
signed char type, kind;
assert (auxp);
type = _CFI_decode_type(auxp->type);
kind = _CFI_decode_kind(auxp->type);
assert (type == CFI_type_Complex);
switch (kind)
{
case 4:
return c_vrfy_c_float_complex (auxp);
break;
case 8:
return c_vrfy_c_double_complex (auxp);
break;
case 10:
return c_vrfy_c_long_double_complex (auxp);
break;
case 16:
return c_vrfy_c_float128_complex (auxp);
break;
default:
assert (false);
}
return true;
}
void
check_tk (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed char kind, const size_t elem_len, const size_t nelem)
{
signed char ityp, iknd;
assert (auxp);
assert (auxp->elem_len==elem_len*nelem);
assert (auxp->rank==1);
assert (auxp->dim[0].sm>0);
assert ((size_t)auxp->dim[0].sm==elem_len*nelem);
/* */
assert (auxp->type==type);
ityp = _CFI_decode_type(auxp->type);
assert (ityp == CFI_type_Complex);
iknd = _CFI_decode_kind(auxp->type);
assert (_CFI_decode_type(type)==ityp);
assert (kind==iknd);
assert (c_vrfy_complex (auxp));
return;
}
// Local Variables:
// mode: C
// End:

Fortran/gfortran/regression/PR100914.f90

! Fails on x86 targets where sizeof(long double) == 16.
! { dg-do run }
! { dg-additional-sources PR100914.c }
! { dg-require-effective-target fortran_real_c_float128 }
! { dg-additional-options "-Wno-pedantic" }
!
! Test the fix for PR100914
!
module isof_m
use, intrinsic :: iso_c_binding, only: &
c_signed_char, c_int16_t
implicit none
private
public :: &
CFI_type_Complex, &
CFI_type_float_Complex, &
CFI_type_double_Complex, &
CFI_type_long_double_Complex, &
CFI_type_float128_Complex
public :: &
check_tk_as, &
check_tk_ar
public :: &
cfi_encode_type
integer, parameter :: CFI_type_t = c_int16_t
integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t)
integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t
! Intrinsic types. Their kind number defines their storage size. */
integer(kind=c_signed_char), parameter :: CFI_type_Complex = 4
! C-Fortran Interoperability types.
integer(kind=cfi_type_t), parameter :: CFI_type_float_Complex = &
ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(4_c_int16_t, CFI_type_kind_shift))
integer(kind=cfi_type_t), parameter :: CFI_type_double_Complex = &
ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(8_c_int16_t, CFI_type_kind_shift))
integer(kind=cfi_type_t), parameter :: CFI_type_long_double_Complex = &
ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(10_c_int16_t, CFI_type_kind_shift))
integer(kind=cfi_type_t), parameter :: CFI_type_float128_Complex = &
ior(int(CFI_type_Complex, kind=c_int16_t), shiftl(16_c_int16_t, CFI_type_kind_shift))
interface
subroutine check_tk_as(a, t, k, e, n) &
bind(c, name="check_tk")
use, intrinsic :: iso_c_binding, only: &
c_int16_t, c_signed_char, c_size_t
implicit none
type(*), intent(in) :: a(:)
integer(c_int16_t), value, intent(in) :: t
integer(c_signed_char), value, intent(in) :: k
integer(c_size_t), value, intent(in) :: e
integer(c_size_t), value, intent(in) :: n
end subroutine check_tk_as
subroutine check_tk_ar(a, t, k, e, n) &
bind(c, name="check_tk")
use, intrinsic :: iso_c_binding, only: &
c_int16_t, c_signed_char, c_size_t
implicit none
type(*), intent(in) :: a(..)
integer(c_int16_t), value, intent(in) :: t
integer(c_signed_char), value, intent(in) :: k
integer(c_size_t), value, intent(in) :: e
integer(c_size_t), value, intent(in) :: n
end subroutine check_tk_ar
end interface
contains
elemental function cfi_encode_type(type, kind) result(itype)
integer(kind=c_signed_char), intent(in) :: type
integer(kind=c_signed_char), intent(in) :: kind
integer(kind=c_int16_t) :: itype, ikind
itype = int(type, kind=c_int16_t)
itype = iand(itype, CFI_type_mask)
ikind = int(kind, kind=c_int16_t)
ikind = iand(ikind, CFI_type_mask)
ikind = shiftl(ikind, CFI_type_kind_shift)
itype = ior(ikind, itype)
return
end function cfi_encode_type
end module isof_m
module iso_check_m
use, intrinsic :: iso_c_binding, only: &
c_signed_char, c_int16_t, c_size_t
use, intrinsic :: iso_c_binding, only: &
c_float_complex, &
c_double_complex, &
c_long_double_complex, &
c_float128_complex
use :: isof_m, only: &
CFI_type_Complex
use :: isof_m, only: &
CFI_type_float_Complex, &
CFI_type_double_Complex, &
CFI_type_long_double_Complex, &
CFI_type_float128_Complex
use :: isof_m, only: &
check_tk_as, &
check_tk_ar
use :: isof_m, only: &
cfi_encode_type
implicit none
private
public :: &
check_c_float_complex, &
check_c_double_complex, &
check_c_long_double_complex, &
check_c_float128_complex
integer :: i
integer(kind=c_size_t), parameter :: b = 8
integer, parameter :: n = 11
complex(kind=c_float_complex), parameter :: ref_c_float_complex(*) = &
[(cmplx(i, 2*i, kind=c_float_complex), i=1,n)]
complex(kind=c_double_complex), parameter :: ref_c_double_complex(*) = &
[(cmplx(i, 2*i, kind=c_double_complex), i=1,n)]
complex(kind=c_long_double_complex), parameter :: ref_c_long_double_complex(*) = &
[(cmplx(i, 2*i, kind=c_long_double_complex), i=1,n)]
complex(kind=c_float128_complex), parameter :: ref_c_float128_complex(*) = &
[(cmplx(i, 2*i, kind=c_float128_complex), i=1,n)]
contains
! CFI_type_float_complex
subroutine check_c_float_complex()
complex(kind=c_float_complex) :: a(n)
!
if (c_float_complex/=4) stop 1
a = ref_c_float_complex
call f_check_c_float_complex_as(a)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 2
a = ref_c_float_complex
call c_check_c_float_complex_as(a)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 3
a = ref_c_float_complex
call f_check_c_float_complex_ar(a)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 4
a = ref_c_float_complex
call c_check_c_float_complex_ar(a)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 5
return
end subroutine check_c_float_complex
subroutine f_check_c_float_complex_as(a)
complex(kind=c_float_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 6
if(k/=4_c_signed_char) stop 7
if(int(k, kind=c_size_t)/=(e/2)) stop 8
if(t/=CFI_type_float_complex) stop 9
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 10
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 11
return
end subroutine f_check_c_float_complex_as
subroutine c_check_c_float_complex_as(a) bind(c)
complex(kind=c_float_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 12
if(k/=4_c_signed_char) stop 13
if(int(k, kind=c_size_t)/=(e/2)) stop 14
if(t/=CFI_type_float_complex) stop 15
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 16
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 17
return
end subroutine c_check_c_float_complex_as
subroutine f_check_c_float_complex_ar(a)
complex(kind=c_float_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 18
if(k/=4_c_signed_char) stop 19
if(int(k, kind=c_size_t)/=(e/2)) stop 20
if(t/=CFI_type_float_complex) stop 21
select rank(a)
rank(1)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 22
rank default
stop 23
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 24
rank default
stop 25
end select
return
end subroutine f_check_c_float_complex_ar
subroutine c_check_c_float_complex_ar(a) bind(c)
complex(kind=c_float_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 26
if(k/=4_c_signed_char) stop 27
if(int(k, kind=c_size_t)/=(e/2)) stop 28
if(t/=CFI_type_float_complex) stop 29
select rank(a)
rank(1)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 30
rank default
stop 31
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_float_complex)>0.0_c_float_complex)) stop 32
rank default
stop 33
end select
return
end subroutine c_check_c_float_complex_ar
! CFI_type_double_complex
subroutine check_c_double_complex()
complex(kind=c_double_complex) :: a(n)
!
if (c_double_complex/=8) stop 34
a = ref_c_double_complex
call f_check_c_double_complex_as(a)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 35
a = ref_c_double_complex
call c_check_c_double_complex_as(a)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 36
a = ref_c_double_complex
call f_check_c_double_complex_ar(a)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 37
a = ref_c_double_complex
call c_check_c_double_complex_ar(a)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 38
return
end subroutine check_c_double_complex
subroutine f_check_c_double_complex_as(a)
complex(kind=c_double_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 39
if(k/=8_c_signed_char) stop 40
if(int(k, kind=c_size_t)/=(e/2)) stop 41
if(t/=CFI_type_double_complex) stop 42
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 43
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 44
return
end subroutine f_check_c_double_complex_as
subroutine c_check_c_double_complex_as(a) bind(c)
complex(kind=c_double_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 45
if(k/=8_c_signed_char) stop 46
if(int(k, kind=c_size_t)/=(e/2)) stop 47
if(t/=CFI_type_double_complex) stop 48
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 49
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 50
return
end subroutine c_check_c_double_complex_as
subroutine f_check_c_double_complex_ar(a)
complex(kind=c_double_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 51
if(k/=8_c_signed_char) stop 52
if(int(k, kind=c_size_t)/=(e/2)) stop 53
if(t/=CFI_type_double_complex) stop 54
select rank(a)
rank(1)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 55
rank default
stop 56
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 57
rank default
stop 58
end select
return
end subroutine f_check_c_double_complex_ar
subroutine c_check_c_double_complex_ar(a) bind(c)
complex(kind=c_double_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 59
if(k/=8_c_signed_char) stop 60
if(int(k, kind=c_size_t)/=(e/2)) stop 61
if(t/=CFI_type_double_complex) stop 62
select rank(a)
rank(1)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 63
rank default
stop 64
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_double_complex)>0.0_c_double_complex)) stop 65
rank default
stop 66
end select
return
end subroutine c_check_c_double_complex_ar
! CFI_type_long_double_complex
subroutine check_c_long_double_complex()
complex(kind=c_long_double_complex) :: a(n)
!
if (c_long_double_complex/=10) stop 67
a = ref_c_long_double_complex
call f_check_c_long_double_complex_as(a)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 68
a = ref_c_long_double_complex
call c_check_c_long_double_complex_as(a)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 69
a = ref_c_long_double_complex
call f_check_c_long_double_complex_ar(a)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 70
a = ref_c_long_double_complex
call c_check_c_long_double_complex_ar(a)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 71
return
end subroutine check_c_long_double_complex
subroutine f_check_c_long_double_complex_as(a)
complex(kind=c_long_double_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 72
if(k/=10_c_signed_char) stop 73
if(e/=32) stop 74
if(t/=CFI_type_long_double_complex) stop 75
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 76
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 77
return
end subroutine f_check_c_long_double_complex_as
subroutine c_check_c_long_double_complex_as(a) bind(c)
complex(kind=c_long_double_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 78
if(k/=10_c_signed_char) stop 79
if(e/=32) stop 80
if(t/=CFI_type_long_double_complex) stop 81
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 82
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 83
return
end subroutine c_check_c_long_double_complex_as
subroutine f_check_c_long_double_complex_ar(a)
complex(kind=c_long_double_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 84
if(k/=10_c_signed_char) stop 85
if(e/=32) stop 86
if(t/=CFI_type_long_double_complex) stop 87
select rank(a)
rank(1)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 88
rank default
stop 89
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 90
rank default
stop 91
end select
return
end subroutine f_check_c_long_double_complex_ar
subroutine c_check_c_long_double_complex_ar(a) bind(c)
complex(kind=c_long_double_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 92
if(k/=10_c_signed_char) stop 93
if(e/=32) stop 94
if(t/=CFI_type_long_double_complex) stop 95
select rank(a)
rank(1)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 96
rank default
stop 97
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_long_double_complex)>0.0_c_long_double_complex)) stop 98
rank default
stop 99
end select
return
end subroutine c_check_c_long_double_complex_ar
! CFI_type_float128_complex
subroutine check_c_float128_complex()
complex(kind=c_float128_complex) :: a(n)
!
if (c_float128_complex/=16) stop 100
a = ref_c_float128_complex
call f_check_c_float128_complex_as(a)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 101
a = ref_c_float128_complex
call c_check_c_float128_complex_as(a)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 102
a = ref_c_float128_complex
call f_check_c_float128_complex_ar(a)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 103
a = ref_c_float128_complex
call c_check_c_float128_complex_ar(a)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 104
return
end subroutine check_c_float128_complex
subroutine f_check_c_float128_complex_as(a)
complex(kind=c_float128_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 105
if(k/=16_c_signed_char) stop 106
if(int(k, kind=c_size_t)/=(e/2)) stop 107
if(t/=CFI_type_float128_complex) stop 108
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 109
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 110
return
end subroutine f_check_c_float128_complex_as
subroutine c_check_c_float128_complex_as(a) bind(c)
complex(kind=c_float128_complex), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 111
if(k/=16_c_signed_char) stop 112
if(int(k, kind=c_size_t)/=(e/2)) stop 113
if(t/=CFI_type_float128_complex) stop 114
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 115
call check_tk_as(a, t, k, e, 1_c_size_t)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 116
return
end subroutine c_check_c_float128_complex_as
subroutine f_check_c_float128_complex_ar(a)
complex(kind=c_float128_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 117
if(k/=16_c_signed_char) stop 118
if(int(k, kind=c_size_t)/=(e/2)) stop 119
if(t/=CFI_type_float128_complex) stop 120
select rank(a)
rank(1)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 121
rank default
stop 122
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 123
rank default
stop 124
end select
return
end subroutine f_check_c_float128_complex_ar
subroutine c_check_c_float128_complex_ar(a) bind(c)
complex(kind=c_float128_complex), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = kind(a)
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_complex, k)
if(k<=0_c_signed_char) stop 125
if(k/=16_c_signed_char) stop 126
if(int(k, kind=c_size_t)/=(e/2)) stop 127
if(t/=CFI_type_float128_complex) stop 128
select rank(a)
rank(1)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 129
rank default
stop 130
end select
call check_tk_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
if(any(abs(a-ref_c_float128_complex)>0.0_c_float128_complex)) stop 131
rank default
stop 132
end select
return
end subroutine c_check_c_float128_complex_ar
end module iso_check_m
program main_p
use :: iso_check_m, only: &
check_c_float_complex, &
check_c_double_complex, &
check_c_long_double_complex, &
check_c_float128_complex
implicit none
call check_c_float_complex()
call check_c_double_complex()
! see PR100910
! call check_c_long_double_complex()
call check_c_float128_complex()
stop
end program main_p
!! Local Variables:
!! mode: f90
!! End:

Fortran/gfortran/regression/PR100915.c

/* Test the fix for PR100915 */
#include <assert.h>
#include <stdbool.h>
#include <stdio.h>
#include <ISO_Fortran_binding.h>
#define _CFI_type_mask 0xFF
#define _CFI_type_kind_shift 8
#define _CFI_decode_type(NAME) (signed char)((NAME) & CFI_type_mask)
#define _CFI_decode_kind(NAME) (signed char)(((NAME) >> CFI_type_kind_shift) & CFI_type_mask)
#define _CFI_encode_type(TYPE, KIND) (int16_t)\
((((KIND) & CFI_type_mask) << CFI_type_kind_shift)\
| ((TYPE) & CFI_type_mask))
#define N 11
#define M 7
typedef int(*c_funptr)(int);
bool c_vrfy_c_funptr (const CFI_cdesc_t *restrict);
void check_fn (const CFI_cdesc_t*restrict, const CFI_type_t, const signed char, const size_t, const size_t);
bool
c_vrfy_c_funptr (const CFI_cdesc_t *restrict auxp)
{
CFI_index_t i, lb, ub, ex;
size_t sz;
c_funptr *ip = NULL;
assert (auxp);
assert (auxp->base_addr);
assert (auxp->elem_len>0);
lb = auxp->dim[0].lower_bound;
ex = auxp->dim[0].extent;
assert (ex==11);
sz = (size_t)auxp->elem_len / sizeof (c_funptr);
assert (sz==1);
ub = ex + lb - 1;
ip = (c_funptr*)auxp->base_addr;
for (i=0; i<ex; i++, ip+=sz)
if ((**ip)((int)(i)) != 2*(int)(i))
return false;
for (i=lb; i<ub+1; i++)
{
ip = (c_funptr*)CFI_address(auxp, &i);
if ((**ip)((int)(i-lb)) != 2*(int)(i-lb))
return false;
}
return true;
}
void
check_fn (const CFI_cdesc_t *restrict auxp, const CFI_type_t type, const signed char kind, const size_t elem_len, const size_t nelem)
{
signed char ityp, iknd;
assert (auxp);
assert (auxp->elem_len==elem_len*nelem);
assert (auxp->rank==1);
assert (auxp->dim[0].sm>0);
assert ((size_t)auxp->dim[0].sm==elem_len*nelem);
/* */
assert (auxp->type==type);
ityp = _CFI_decode_type(auxp->type);
assert (ityp == CFI_type_cfunptr);
iknd = _CFI_decode_kind(auxp->type);
assert (_CFI_decode_type(type)==ityp);
assert (kind==iknd);
assert (c_vrfy_c_funptr (auxp));
return;
}
// Local Variables:
// mode: C
// End:

Fortran/gfortran/regression/PR100915.f90

! { dg-do run }
! { dg-additional-sources PR100915.c }
!
! Test the fix for PR100915
!
module isof_m
use, intrinsic :: iso_c_binding, only: &
c_signed_char, c_int16_t
implicit none
private
public :: &
CFI_type_cptr, CFI_type_cfunptr
public :: &
check_fn_as, &
check_fn_ar
public :: &
mult2
public :: &
cfi_encode_type
integer, parameter :: CFI_type_t = c_int16_t
integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t)
integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t
! Intrinsic types. Their kind number defines their storage size. */
integer(kind=c_signed_char), parameter :: CFI_type_cptr = 7
integer(kind=c_signed_char), parameter :: CFI_type_cfunptr = 8
interface
subroutine check_fn_as(a, t, k, e, n) &
bind(c, name="check_fn")
use, intrinsic :: iso_c_binding, only: &
c_int16_t, c_signed_char, c_size_t
implicit none
type(*), intent(in) :: a(:)
integer(c_int16_t), value, intent(in) :: t
integer(c_signed_char), value, intent(in) :: k
integer(c_size_t), value, intent(in) :: e
integer(c_size_t), value, intent(in) :: n
end subroutine check_fn_as
subroutine check_fn_ar(a, t, k, e, n) &
bind(c, name="check_fn")
use, intrinsic :: iso_c_binding, only: &
c_int16_t, c_signed_char, c_size_t
implicit none
type(*), intent(in) :: a(..)
integer(c_int16_t), value, intent(in) :: t
integer(c_signed_char), value, intent(in) :: k
integer(c_size_t), value, intent(in) :: e
integer(c_size_t), value, intent(in) :: n
end subroutine check_fn_ar
end interface
contains
function mult2(a) result(b) bind(c)
use, intrinsic :: iso_c_binding, only: &
c_int
integer(kind=c_int), value, intent(in) :: a
integer(kind=c_int) :: b
b = 2_c_int * a
return
end function mult2
elemental function cfi_encode_type(type, kind) result(itype)
integer(kind=c_signed_char), intent(in) :: type
integer(kind=c_signed_char), intent(in) :: kind
integer(kind=c_int16_t) :: itype, ikind
itype = int(type, kind=c_int16_t)
itype = iand(itype, CFI_type_mask)
ikind = int(kind, kind=c_int16_t)
ikind = iand(ikind, CFI_type_mask)
ikind = shiftl(ikind, CFI_type_kind_shift)
itype = ior(ikind, itype)
return
end function cfi_encode_type
end module isof_m
module iso_check_m
use, intrinsic :: iso_c_binding, only: &
c_signed_char, c_int16_t, c_size_t
use, intrinsic :: iso_c_binding, only: &
c_funptr, c_funloc, c_associated
use :: isof_m, only: &
CFI_type_cptr, CFI_type_cfunptr
use :: isof_m, only: &
check_fn_as, &
check_fn_ar
use :: isof_m, only: &
mult2
use :: isof_m, only: &
cfi_encode_type
implicit none
integer :: i
integer(kind=c_size_t), parameter :: b = 8
integer, parameter :: n = 11
contains
subroutine check_c_funptr()
type(c_funptr) :: p(n)
integer :: i
!
p = [(c_funloc(mult2), i=1,n)]
call f_check_c_funptr_as(p)
do i = 1, n
if(.not.c_associated(p(i), c_funloc(mult2))) stop 1
end do
p = [(c_funloc(mult2), i=1,n)]
call c_check_c_funptr_as(p)
do i = 1, n
if(.not.c_associated(p(i), c_funloc(mult2))) stop 2
end do
p = [(c_funloc(mult2), i=1,n)]
call f_check_c_funptr_ar(p)
do i = 1, n
if(.not.c_associated(p(i), c_funloc(mult2))) stop 3
end do
p = [(c_funloc(mult2), i=1,n)]
call c_check_c_funptr_ar(p)
do i = 1, n
if(.not.c_associated(p(i), c_funloc(mult2))) stop 4
end do
return
end subroutine check_c_funptr
subroutine f_check_c_funptr_as(a)
type(c_funptr), intent(in) :: a(:)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = 0
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_cfunptr, k)
! Assumes 64-bit target.
! if(e/=8) stop 5
do i = 1, n
if(.not.c_associated(a(i), c_funloc(mult2))) stop 6
end do
call check_fn_as(a, t, k, e, 1_c_size_t)
do i = 1, n
if(.not.c_associated(a(i), c_funloc(mult2))) stop 7
end do
return
end subroutine f_check_c_funptr_as
subroutine c_check_c_funptr_as(a) bind(c)
type(c_funptr), intent(in) :: a(:)
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = 0
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_cfunptr, k)
! Assumes 64-bit target.
! if(e/=8) stop 8
do i = 1, n
if(.not.c_associated(a(i), c_funloc(mult2))) stop 9
end do
call check_fn_as(a, t, k, e, 1_c_size_t)
do i = 1, n
if(.not.c_associated(a(i), c_funloc(mult2))) stop 10
end do
return
end subroutine c_check_c_funptr_as
subroutine f_check_c_funptr_ar(a)
type(c_funptr), intent(in) :: a(..)
!
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = 0
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_cfunptr, k)
! Assumes 64-bit target.
! if(e/=8) stop 11
select rank(a)
rank(1)
do i = 1, n
if(.not.c_associated(a(i), c_funloc(mult2))) stop 12
end do
rank default
stop 13
end select
call check_fn_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
do i = 1, n
if(.not.c_associated(a(i), c_funloc(mult2))) stop 14
end do
rank default
stop 15
end select
return
end subroutine f_check_c_funptr_ar
subroutine c_check_c_funptr_ar(a) bind(c)
type(c_funptr), intent(in) :: a(..)
integer(kind=c_int16_t) :: t
integer(kind=c_signed_char) :: k
integer(kind=c_size_t) :: e
!
k = 0
e = storage_size(a)/b
t = cfi_encode_type(CFI_type_cfunptr, k)
! Assumes 64-bit target.
! if(e/=8) stop 16
select rank(a)
rank(1)
do i = 1, n
if(.not.c_associated(a(i), c_funloc(mult2))) stop 17
end do
rank default
stop 18
end select
call check_fn_ar(a, t, k, e, 1_c_size_t)
select rank(a)
rank(1)
do i = 1, n
if(.not.c_associated(a(i), c_funloc(mult2))) stop 19
end do
rank default
stop 20
end select
return
end subroutine c_check_c_funptr_ar
end module iso_check_m
program main_p
use :: iso_check_m, only: &
check_c_funptr
implicit none
call check_c_funptr()
stop
end program main_p
!! Local Variables:
!! mode: f90
!! End:

Fortran/gfortran/regression/PR19754_1.f90

! { dg-do compile }
! Test of fix to PR19754
program PR19754_1
real x(3,3),y(2,2)
x = 1.
y = 2.
x = x + y ! { dg-error "Shapes for operands at" }
end program PR19754_1

Fortran/gfortran/regression/PR19754_2.f90

! { dg-do run }
! Test of Steve Kargl's fix to PR19754
! This exercises bugs that the original patch caused
!
program PR19754_2
real a(2,2), b(2,2),c(2,2),d(2,2)
integer i(2,2),j(2,2),k(2,2)
a = 1. ; b = 2. ; i = 4
c = b - floor( a / b ) ! this caused an ICE
d = b - real(floor( a / b ))
if (any (c/=d)) STOP 1
j = aint(b) - floor( a / b ) ! this caused an ICE
if (any(real(j)/=d)) STOP 2
c = i
if (any(real(i)/=c)) STOP 3
c = i + b ! this caused an ICE
d = real(i) + b
if (any(c/=d)) STOP 4
j = i + aint (a)
k = i + a ! this caused an ICE
if (any(j/=k)) STOP 5
end program PR19754_2

Fortran/gfortran/regression/PR19872.f

! { dg-do run { target fd_truncate } }
! PR 19872 - closed and re-opened file not overwriten
implicit none
integer i(4)
data i / 4 * 0 /
open(1,form='FORMATTED',status='UNKNOWN')
write(1,'("1 2 3 4 5 6 7 8 9")')
close(1)
open(1,form='FORMATTED')
write(1,'("9 8 7 6")')
close(1)
open(1,form='FORMATTED')
read(1,*)i
if(i(1).ne.9.or.i(2).ne.8.or.i(3).ne.7.or.i(4).ne.6)STOP 1
read(1,*, end=200)i
! should only be able to read one line from the file
STOP 2
200 continue
close(1,STATUS='delete')
end

Fortran/gfortran/regression/PR24188.f

C PR target/24188
C { dg-do compile }
C { dg-options "-O2" }
C { dg-options "-O2 -mcmodel=medium" { target { { i?86-*-* x86_64-*-* } && lp64 } } }
WRITE(6,*) ''
END

Fortran/gfortran/regression/PR37039.f90

! { dg-do compile }
! { dg-options "-fcray-pointer" }
!
! Test for PR37039, from an issue on comp.lang.fortran
! http://groups.google.com/group/comp.lang.fortran/msg/8cfa06f222721386
subroutine test(nnode)
implicit none
integer n,nnode
pointer(ip_tab, tab)
integer , dimension(1:nnode) :: tab
do n=1,nnode
tab(n) = 0
enddo
end subroutine test

Fortran/gfortran/regression/PR40660.f90

! { dg-do compile }
! { dg-options "-fdump-tree-original-lineno" }
!
! PR fortran/40660
PROGRAM test
INTEGER, DIMENSION(3) :: a1,a2
a1 = 1
PRINT*, a1
a2 = 2
end program test
! { dg-final { scan-tree-dump-times ": 3\] _gfortran" 0 "original" } }

Fortran/gfortran/regression/PR49268.f90

! { dg-do run }
! { dg-options "-fcray-pointer" }
! Test the fix for a runtime error
! Contributed by Mike Kumbera <kumbera1@llnl.gov>
program bob
implicit none
integer*8 ipfoo
integer n,m,i,j
real*8 foo
common /ipdata/ ipfoo
common /ipsize/ n,m
POINTER ( ipfoo, foo(3,7) )
n=3
m=7
ipfoo=malloc(8*n*m)
do i=1,n
do j=1,m
foo(i,j)=1.d0
end do
end do
call use_foo()
end program bob
subroutine use_foo()
implicit none
integer n,m,i,j
integer*8 ipfoo
common /ipdata/ ipfoo
common /ipsize/ n,m
real*8 foo,boo
!fails if * is the last dimension
POINTER ( ipfoo, foo(n,*) )
!works if the last dimension is specified
!POINTER ( ipfoo, foo(n,m) )
boo=0.d0
do i=1,n
do j=1,m
boo=foo(i,j)+1.0
if (abs (boo - 2.0) .gt. 1e-6) STOP 1
end do
end do
end subroutine use_foo

Fortran/gfortran/regression/PR82376.f90

! { dg-do compile }
! { dg-options "-fdump-tree-original -fcheck=pointer" }
!
! Test the fix for PR82376. The pointer check was doubling up the call
! to new. The fix reduces the count of 'new' from 5 to 4, or to 3, when
! counting only calls.
!
! Contributed by José Rui Faustino de Sousa <jrfsousa@gmail.com>
!
program main_p
integer, parameter :: n = 10
type :: foo_t
integer, pointer :: v =>null()
end type foo_t
integer, save :: pcnt = 0
type(foo_t) :: int
integer :: i
do i = 1, n
call init(int, i)
if(.not.associated(int%v)) stop 1
if(int%v/=i) stop 2
if(pcnt/=i) stop 3
end do
contains
function new(data) result(this)
integer, target, intent(in) :: data
integer, pointer :: this
nullify(this)
this => data
pcnt = pcnt + 1
return
end function new
subroutine init(this, data)
type(foo_t), intent(out) :: this
integer, intent(in) :: data
call set(this, new(data))
return
end subroutine init
subroutine set(this, that)
type(foo_t), intent(inout) :: this
integer, target, intent(in) :: that
this%v => that
return
end subroutine set
end program main_p
! { dg-final { scan-tree-dump-times { new \(} 3 "original" } }

Fortran/gfortran/regression/PR85868A.f90

! { dg-do run }
!
! PR fortran/85868
!
! Contributed by Harald Anlauf <anlauf@gmx.de>
!
program test
implicit none
integer, parameter :: e(*) = [1, 1, -1, -1, 0, 0, 1]
integer, pointer :: t(:), u(:)
integer :: i
allocate (t(-1:5))
do i = -1, 5
t(i) = i
end do
call p (t, e(1)) ! Pointer with lower bound = -1 from allocation
u => t ! Pointer assignment sets same lower bound
call p (u, e(2))
!
u => t(:) ! Pointer assignment with implicit lower bound (1)
call p (u, e(3))
call p (t(:), e(4)) ! Full array, behaves the same
!
call p (t(0:), e(5)) ! Array section
u => t(0:) ! Pointer assignment with implicit lower bound (1)
call p (u, e(6))
u(0:) => t(0:) ! Pointer assignment with given lower bound (0)
call p (u, e(7))
stop
contains
subroutine p (a, v)
integer, pointer, intent(in) :: a(:)
integer, intent(in) :: v
if(a(1)/=v) stop 1001
return
end subroutine p
end program test

Fortran/gfortran/regression/PR85868B.f90

program main_p
implicit none
integer, parameter :: n = 10
integer, parameter :: m = 5
integer, parameter :: b = 3
integer, parameter :: t = n+b-1
integer, parameter :: l = 4
integer, parameter :: u = 7
integer, parameter :: s = 3
integer, parameter :: e = (u-l)/s+1
call test_f()
call test_s()
call test_p()
call test_a()
stop
contains
subroutine test_f()
integer, target :: x(n,n)
integer, target :: y(b:t)
integer :: i
x = reshape([(i, i=1,n*n)], [n,n])
y = x(:,m)
call sub_s(x(:,m), y, 1, n, n)
call sub_s(y, x(:,m), b, t, n)
return
end subroutine test_f
subroutine test_s()
integer, target :: x(n,n)
integer, target :: v(e)
integer :: i
x = reshape([(i, i=1,n*n)], [n,n])
v = x(l:u:s,m)
call sub_s(v, v, 1, e, e)
call sub_s(x(l:u:s,m), v, 1, e, e)
call sub_s(v, x(l:u:s,m), 1, e, e)
return
end subroutine test_s
subroutine test_p()
integer, target :: x(n,n)
integer, pointer :: p(:)
integer :: v(e)
integer :: i
x = reshape([(i, i=1,n*n)], [n,n])
v = x(l:u:s,m)
p => x(:,m)
call sub_s(p(l:u:s), v, 1, e, e)
p => x(l:u:s,m)
call sub_s(p, v, 1, e, e)
p(l:) => x(l:u:s,m)
call sub_s(p, v, l, e+l-1, e)
p(l:l+e-1) => x(l:u:s,m)
call sub_s(p, v, l, e+l-1, e)
allocate(p(n))
p(:) = x(:,m)
call sub_s(p(l:u:s), v, 1, e, e)
deallocate(p)
allocate(p(e))
p(:) = x(l:u:s,m)
call sub_s(p, v, 1, e, e)
deallocate(p)
allocate(p(l:l+e-1))
p(:) = x(l:u:s,m)
call sub_s(p, v, l, e+l-1, e)
deallocate(p)
allocate(p(l:l+e-1))
p(l:) = x(l:u:s,m)
call sub_s(p, v, l, e+l-1, e)
deallocate(p)
allocate(p(l:l+e-1))
p(l:l+e-1) = x(l:u:s,m)
call sub_s(p, v, l, e+l-1, e)
deallocate(p)
return
end subroutine test_p
subroutine test_a()
integer :: x(n,n)
integer, allocatable, target :: a(:)
integer :: v(e)
integer :: i
x = reshape([(i, i=1,n*n)], [n,n])
v = x(l:u:s,m)
a = x(:,m)
call sub_s(a(l:u:s), v, 1, e, e)
deallocate(a)
allocate(a(n))
a(:) = x(:,m)
call sub_s(a(l:u:s), v, 1, e, e)
deallocate(a)
a = x(l:u:s,m)
call sub_s(a, v, 1, e, e)
deallocate(a)
allocate(a(e))
a(:) = x(l:u:s,m)
call sub_s(a, v, 1, e, e)
deallocate(a)
allocate(a(l:l+e-1))
a(:) = x(l:u:s,m)
call sub_s(a, v, l, e+l-1, e)
deallocate(a)
allocate(a(l:l+e-1))
a(l:) = x(l:u:s,m)
call sub_s(a, v, l, e+l-1, e)
deallocate(a)
allocate(a(l:l+e-1))
a(l:l+e-1) = x(l:u:s,m)
call sub_s(a, v, l, e+l-1, e)
deallocate(a)
return
end subroutine test_a
subroutine sub_s(a, b, l, u, e)
integer, pointer, intent(in) :: a(:)
integer, intent(in) :: b(:)
integer, intent(in) :: l
integer, intent(in) :: u
integer, intent(in) :: e
integer :: i
if(lbound(a,dim=1)/=l) stop 1001
if(ubound(a,dim=1)/=u) stop 1002
if(any(shape(a)/=[e])) stop 1003
if(size(a, dim=1)/=e) stop 1004
if(size(a)/=size(b)) stop 1005
do i = l, u
if(a(i)/=b(i-l+1)) stop 1006
end do
end subroutine sub_s
end program main_p

Fortran/gfortran/regression/PR90350.f90

! { dg-do compile }
!
! Test the fix for PR90350
!
! Contributed by <urbanjost@comcast.net>
!
program artificial
implicit none
integer :: arr(-10:10)
call asub(arr,size(arr))
end program artificial
subroutine asub(arr,n)
integer,intent(in) :: arr(*)
integer,intent(in) :: n
write(*,*)'UPPER=',ubound(arr(:n))
write(*,*)'LOWER=',lbound(arr(:n))
write(*,*)'SIZE=',size(arr(:n))
end subroutine asub

Fortran/gfortran/regression/PR93308.f90

! { dg-do run }
!
! Test the fix for PR94331
!
! Contributed by Robin Hogan <r.j.hogan@reading.ac.uk>
!
program test
use, intrinsic :: iso_c_binding, only: &
c_int, c_float
implicit none
integer :: i
integer, parameter :: n = 11
real(kind=c_float), parameter :: u(*) = [(real(i, kind=c_float), i=1,n)]
real(kind=c_float), allocatable :: A(:)
real(kind=c_float) :: E(n)
integer(kind=c_int) :: l1, l2, l3
allocate(A, source=u)
l1 = lbound(A, 1)
call routine_bindc(A, l2) ! in gcc-9.2.1 this changes lbound of A...
l3 = lbound(A, 1)
if (l1 /= 1) stop 1
if (l1 /= l2) stop 2
if (l1 /= l3) stop 3
if (any(abs(A(1:n)-u)>0.0_c_float)) stop 4
deallocate(A)
!
E = u
l1 = lbound(E, 1)
call routine_bindc(E, l2) ! ...but does not change lbound of E
l3 = lbound(E, 1)
if (l1 /= 1) stop 5
if (l1 /= l2) stop 6
if (l1 /= l3) stop 7
if (any(abs(E(1:n)-u)>0.0_c_float)) stop 8
contains
subroutine routine_bindc(v, l) bind(c)
real(kind=c_float), intent(inout) :: v(:)
integer(kind=c_int), intent(out) :: l
l = lbound(v, 1)
if (any(abs(v(1:n)-u)>0.0_c_float)) stop 9
end subroutine routine_bindc
end program test

Fortran/gfortran/regression/PR93963.f90

! { dg-do run }
! { dg-additional-options "-fdump-tree-original" }
!
! Test the fix for PR93963
!
module m
contains
function rank_p(this) result(rnk) bind(c)
use, intrinsic :: iso_c_binding, only: c_int
implicit none
integer(kind=c_int), pointer, intent(in) :: this(..)
integer(kind=c_int) :: rnk
select rank(this)
rank(0)
rnk = 0
rank(1)
rnk = 1
rank(2)
rnk = 2
rank(3)
rnk = 3
rank(4)
rnk = 4
rank(5)
rnk = 5
rank(6)
rnk = 6
rank(7)
rnk = 7
rank(8)
rnk = 8
rank(9)
rnk = 9
rank(10)
rnk = 10
rank(11)
rnk = 11
rank(12)
rnk = 12
rank(13)
rnk = 13
rank(14)
rnk = 14
rank(15)
rnk = 15
rank default
rnk = -1000
end select
return
end function rank_p
function rank_a(this) result(rnk) bind(c)
use, intrinsic :: iso_c_binding, only: c_int
implicit none
integer(kind=c_int), allocatable, intent(in) :: this(..)
integer(kind=c_int) :: rnk
select rank(this)
rank(0)
rnk = 0
rank(1)
rnk = 1
rank(2)
rnk = 2
rank(3)
rnk = 3
rank(4)
rnk = 4
rank(5)
rnk = 5
rank(6)
rnk = 6
rank(7)
rnk = 7
rank(8)
rnk = 8
rank(9)
rnk = 9
rank(10)
rnk = 10
rank(11)
rnk = 11
rank(12)
rnk = 12
rank(13)
rnk = 13
rank(14)
rnk = 14
rank(15)
rnk = 15
rank default
rnk = -1000
end select
return
end function rank_a
function rank_o(this) result(rnk) bind(c)
use, intrinsic :: iso_c_binding, only: c_int
implicit none
integer(kind=c_int), intent(in) :: this(..)
integer(kind=c_int) :: rnk
select rank(this)
rank(0)
rnk = 0
rank(1)
rnk = 1
rank(2)
rnk = 2
rank(3)
rnk = 3
rank(4)
rnk = 4
rank(5)
rnk = 5
rank(6)
rnk = 6
rank(7)
rnk = 7
rank(8)
rnk = 8
rank(9)
rnk = 9
rank(10)
rnk = 10
rank(11)
rnk = 11
rank(12)
rnk = 12
rank(13)
rnk = 13
rank(14)
rnk = 14
rank(15)
rnk = 15
rank default
rnk = -1000
end select
return
end function rank_o
end module m
program selr_p
use m
use, intrinsic :: iso_c_binding, only: c_int
implicit none
integer(kind=c_int), parameter :: siz = 7
integer(kind=c_int), parameter :: rnk = 1
integer(kind=c_int), pointer :: intp(:)
integer(kind=c_int), allocatable :: inta(:)
integer(kind=c_int) :: irnk
nullify(intp)
irnk = rank_p(intp)
if (irnk /= rnk) stop 1
if (irnk /= rank(intp)) stop 2
!
irnk = rank_a(inta)
if (irnk /= rnk) stop 3
if (irnk /= rank(inta)) stop 4
!
allocate(intp(siz))
irnk = rank_p(intp)
if (irnk /= rnk) stop 5
if (irnk /= rank(intp)) stop 6
irnk = rank_o(intp)
if (irnk /= rnk) stop 7
if (irnk /= rank(intp)) stop 8
deallocate(intp)
nullify(intp)
!
allocate(inta(siz))
irnk = rank_a(inta)
if (irnk /= rnk) stop 9
if (irnk /= rank(inta)) stop 10
irnk = rank_o(inta)
if (irnk /= rnk) stop 11
if (irnk /= rank(inta)) stop 12
deallocate(inta)
end program selr_p
! Special code for assumed rank - but only if not allocatable/pointer
! Thus, expect it only once for subroutine rank_o but not for rank_a or rank_p
! { dg-final { scan-tree-dump-times "ubound != -1" 1 "original" } }

Fortran/gfortran/regression/PR94022.f90

! { dg-do run }
!
! Test the fix for PR94022
!
function isasa_f(a) result(s)
implicit none
integer, intent(in) :: a(..)
logical :: s
select rank(a)
rank(*)
s = .true.
rank default
s = .false.
end select
return
end function isasa_f
function isasa_c(a) result(s) bind(c)
use, intrinsic :: iso_c_binding, only: c_int, c_bool
implicit none
integer(kind=c_int), intent(in) :: a(..)
logical(kind=c_bool) :: s
select rank(a)
rank(*)
s = .true.
rank default
s = .false.
end select
return
end function isasa_c
program isasa_p
implicit none
interface
function isasa_f(a) result(s)
implicit none
integer, intent(in) :: a(..)
logical :: s
end function isasa_f
function isasa_c(a) result(s) bind(c)
use, intrinsic :: iso_c_binding, only: c_int, c_bool
implicit none
integer(kind=c_int), intent(in) :: a(..)
logical(kind=c_bool) :: s
end function isasa_c
end interface
integer, parameter :: sz = 7
integer, parameter :: lb = 3
integer, parameter :: ub = 9
integer, parameter :: ex = ub-lb+1
integer :: arr(sz,lb:ub)
arr = 1
if (asaf_a(arr, lb+1, ub-1)) stop 1
if (asaf_p(arr, lb+1, ub-1)) stop 2
if (asaf_a(arr, 2, ex-1)) stop 3
if (asaf_p(arr, 2, ex-1)) stop 4
if (asac_a(arr, lb+1, ub-1)) stop 5
if (asac_p(arr, lb+1, ub-1)) stop 6
if (asac_a(arr, 2, ex-1)) stop 7
if (asac_p(arr, 2, ex-1)) stop 8
stop
contains
function asaf_a(a, lb, ub) result(s)
integer, intent(in) :: lb
integer, target, intent(in) :: a(sz,lb:*)
integer, intent(in) :: ub
logical :: s
s = isasa_f(a(:,lb:ub))
return
end function asaf_a
function asaf_p(a, lb, ub) result(s)
integer, intent(in) :: lb
integer, target, intent(in) :: a(sz,lb:*)
integer, intent(in) :: ub
logical :: s
integer, pointer :: p(:,:)
p => a(:,lb:ub)
s = isasa_f(p)
return
end function asaf_p
function asac_a(a, lb, ub) result(s)
integer, intent(in) :: lb
integer, target, intent(in) :: a(sz,lb:*)
integer, intent(in) :: ub
logical :: s
s = logical(isasa_c(a(:,lb:ub)))
return
end function asac_a
function asac_p(a, lb, ub) result(s)
integer, intent(in) :: lb
integer, target, intent(in) :: a(sz,lb:*)
integer, intent(in) :: ub
logical :: s
integer, pointer :: p(:,:)
p => a(:,lb:ub)
s = logical(isasa_c(p))
return
end function asac_p
end program isasa_p

Fortran/gfortran/regression/PR94104a.f90

! { dg-do compile }
! { dg-options "-std=f2003" }
!
! PR fortran/94104
!
program diag_p
implicit none
integer, parameter :: n = 7
integer :: a(n)
integer, target :: b(n)
a = 1
print *, sumf(a) ! { dg-error "Actual argument for 'a' at .1. must be a pointer" }
print *, sumf(b) ! { dg-error "Fortran 2008: Non-pointer actual argument at .1. to pointer dummy 'a'" }
contains
function sumf(a) result(s)
integer, pointer, intent(in) :: a(:)
integer :: s
s = sum(a)
end function sumf
end program diag_p

Fortran/gfortran/regression/PR94104b.f90

! { dg-do compile }
! { dg-options "-std=f2008" }
!
! PR fortran/94104
!
program diag_p
implicit none
integer, parameter :: n = 7
integer :: a(n)
integer, target :: b(n)
a = 1
print *, sumf(a) ! { dg-error "Actual argument for 'a' at .1. must be a pointer or a valid target" }
print *, sumf(b)
contains
function sumf(a) result(s)
integer, pointer, intent(in) :: a(:)
integer :: s
s = sum(a)
end function sumf
end program diag_p

Fortran/gfortran/regression/PR94110.f90

! { dg-do compile }
!
! Test the fix for PR94110
!
program asa_p
implicit none
integer, parameter :: n = 7
type t
end type t
interface
subroutine fc2 (x)
import :: t
class(t), pointer, intent(in) :: x(..)
end subroutine
end interface
integer :: p(n)
integer :: s
p = 1
s = sumf_as(p)
if (s/=n) stop 1
s = sumf_ar(p)
if (s/=n) stop 2
stop
contains
function sumf_as(a) result(s)
integer, target, intent(in) :: a(*)
integer :: s
s = sum_as(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" }
s = sum_p_ds(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" }
s = sum_p_ar(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" }
return
end function sumf_as
function sumf_ar(a) result(s)
integer, target, intent(in) :: a(..)
integer :: s
select rank(a)
rank(*)
s = sum_as(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" }
s = sum_p_ds(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" }
s = sum_p_ar(a) ! { dg-error "Actual argument for .a. cannot be an assumed-size array" }
rank default
stop 3
end select
return
end function sumf_ar
function sum_as(a) result(s)
integer, intent(in) :: a(:)
integer :: s
s = sum(a)
return
end function sum_as
function sum_p_ds(a) result(s)
integer, pointer, intent(in) :: a(:)
integer :: s
s = -1
if(associated(a))&
s = sum(a)
return
end function sum_p_ds
function sum_p_ar(a) result(s)
integer, pointer, intent(in) :: a(..)
integer :: s
s = -1
select rank(a)
rank(1)
if(associated(a))&
s = sum(a)
rank default
stop 4
end select
return
end function sum_p_ar
subroutine sub1(y)
type(t), target :: y(*)
call fc2 (y) ! { dg-error "Actual argument for .x. cannot be an assumed-size array" }
end subroutine sub1
end program asa_p

Fortran/gfortran/regression/PR94289.f90

! { dg-do run }
!
! Testcase for PR 94289
!
! - if the dummy argument is a pointer/allocatable, it has the same
! bounds as the dummy argument
! - if is is nonallocatable nonpointer, the lower bounds are [1, 1, 1].
module bounds_m
implicit none
private
public :: &
lb, ub
public :: &
bnds_p, &
bnds_a, &
bnds_e
integer, parameter :: lb1 = 3
integer, parameter :: lb2 = 5
integer, parameter :: lb3 = 9
integer, parameter :: ub1 = 4
integer, parameter :: ub2 = 50
integer, parameter :: ub3 = 11
integer, parameter :: ex1 = ub1 - lb1 + 1
integer, parameter :: ex2 = ub2 - lb2 + 1
integer, parameter :: ex3 = ub3 - lb3 + 1
integer, parameter :: lf(*) = [1,1,1]
integer, parameter :: lb(*) = [lb1,lb2,lb3]
integer, parameter :: ub(*) = [ub1,ub2,ub3]
integer, parameter :: ex(*) = [ex1,ex2,ex3]
contains
subroutine bounds(a, lb, ub)
integer, pointer, intent(in) :: a(..)
integer, intent(in) :: lb(3)
integer, intent(in) :: ub(3)
integer :: ex(3)
ex = max(ub-lb+1, 0)
if(any(lbound(a)/=lb)) stop 101
if(any(ubound(a)/=ub)) stop 102
if(any( shape(a)/=ex)) stop 103
return
end subroutine bounds
subroutine bnds_p(this)
integer, pointer, intent(in) :: this(..)
if(any(lbound(this)/=lb)) stop 1
if(any(ubound(this)/=ub)) stop 2
if(any( shape(this)/=ex)) stop 3
call bounds(this, lb, ub)
return
end subroutine bnds_p
subroutine bnds_a(this)
integer, allocatable, target, intent(in) :: this(..)
if(any(lbound(this)/=lb)) stop 4
if(any(ubound(this)/=ub)) stop 5
if(any( shape(this)/=ex)) stop 6
call bounds(this, lb, ub)
return
end subroutine bnds_a
subroutine bnds_e(this)
integer, target, intent(in) :: this(..)
if(any(lbound(this)/=lf)) stop 7
if(any(ubound(this)/=ex)) stop 8
if(any( shape(this)/=ex)) stop 9
call bounds(this, lf, ex)
return
end subroutine bnds_e
end module bounds_m
program bounds_p
use, intrinsic :: iso_c_binding, only: c_int
use bounds_m
implicit none
integer, parameter :: fpn = 1
integer, parameter :: fan = 2
integer, parameter :: fon = 3
integer :: i
do i = fpn, fon
call test_p(i)
end do
do i = fpn, fon
call test_a(i)
end do
do i = fpn, fon
call test_e(i)
end do
stop
contains
subroutine test_p(t)
integer, intent(in) :: t
integer, pointer :: a(:,:,:)
allocate(a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)))
select case(t)
case(fpn)
call bnds_p(a)
case(fan)
case(fon)
call bnds_e(a)
case default
stop
end select
deallocate(a)
return
end subroutine test_p
subroutine test_a(t)
integer, intent(in) :: t
integer, allocatable, target :: a(:,:,:)
allocate(a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)))
select case(t)
case(fpn)
call bnds_p(a)
case(fan)
call bnds_a(a)
case(fon)
call bnds_e(a)
case default
stop
end select
deallocate(a)
return
end subroutine test_a
subroutine test_e(t)
integer, intent(in) :: t
integer, target :: a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))
select case(t)
case(fpn)
call bnds_p(a)
case(fan)
case(fon)
call bnds_e(a)
case default
stop
end select
return
end subroutine test_e
end program bounds_p

Fortran/gfortran/regression/PR94327.c

/* Test the fix for PR94327. */
#include <assert.h>
#include <stdbool.h>
#include <stdlib.h>
#include <ISO_Fortran_binding.h>
bool c_vrfy (const CFI_cdesc_t *restrict);
char get_attr (const CFI_cdesc_t*restrict, bool);
bool
c_vrfy (const CFI_cdesc_t *restrict auxp)
{
CFI_index_t i, lb, ub, ex;
int *ip = NULL;
assert (auxp);
assert (auxp->base_addr);
lb = auxp->dim[0].lower_bound;
ex = auxp->dim[0].extent;
ub = ex + lb - 1;
ip = (int*)auxp->base_addr;
for (i=0; i<ex; i++)
if (*ip++ != i+1)
return false;
for (i=lb; i<ub+1; i++)
{
ip = (int*)CFI_address(auxp, &i);
if (*ip != i-lb+1)
return false;
}
return true;
}
char
get_attr (const CFI_cdesc_t *restrict auxp, bool alloc)
{
char attr;
assert (auxp);
assert (auxp->elem_len == 4);
assert (auxp->rank == 1);
assert (auxp->type == CFI_type_int);
attr = '\0';
switch (auxp->attribute)
{
case CFI_attribute_pointer:
if (alloc && !c_vrfy (auxp))
break;
attr = 'p';
break;
case CFI_attribute_allocatable:
if (alloc && !c_vrfy (auxp))
break;
attr = 'a';
break;
case CFI_attribute_other:
assert (alloc);
if (!c_vrfy (auxp))
break;
attr = 'o';
break;
default:
break;
}
return attr;
}

Fortran/gfortran/regression/PR94327.f90

! { dg-do run }
! { dg-additional-sources PR94327.c }
!
! Test the fix for PR94327
!
program attr_p
use, intrinsic :: iso_c_binding, only: &
c_int, c_bool, c_char
implicit none
integer :: i
integer, parameter :: n = 11
integer, parameter :: u(*) = [(i, i=1,n)]
interface
function attr_p_as(a, s) result(c) &
bind(c, name="get_attr")
use, intrinsic :: iso_c_binding, only: &
c_int, c_bool, c_char
implicit none
integer(kind=c_int), pointer, intent(in) :: a(:)
logical(kind=c_bool), value, intent(in) :: s
character(kind=c_char) :: c
end function attr_p_as
function attr_a_as(a, s) result(c) &
bind(c, name="get_attr")
use, intrinsic :: iso_c_binding, only: &
c_int, c_bool, c_char
implicit none
integer(kind=c_int), allocatable, intent(in) :: a(:)
logical(kind=c_bool), value, intent(in) :: s
character(kind=c_char) :: c
end function attr_a_as
function attr_o_as(a, s) result(c) &
bind(c, name="get_attr")
use, intrinsic :: iso_c_binding, only: &
c_int, c_bool, c_char
implicit none
integer(kind=c_int), intent(in) :: a(:)
logical(kind=c_bool), value, intent(in) :: s
character(kind=c_char) :: c
end function attr_o_as
function attr_p_ar(a, s) result(c) &
bind(c, name="get_attr")
use, intrinsic :: iso_c_binding, only: &
c_int, c_bool, c_char
implicit none
integer(kind=c_int), pointer, intent(in) :: a(..)
logical(kind=c_bool), value, intent(in) :: s
character(kind=c_char) :: c
end function attr_p_ar
function attr_a_ar(a, s) result(c) &
bind(c, name="get_attr")
use, intrinsic :: iso_c_binding, only: &
c_int, c_bool, c_char
implicit none
integer(kind=c_int), allocatable, intent(in) :: a(..)
logical(kind=c_bool), value, intent(in) :: s
character(kind=c_char) :: c
end function attr_a_ar
function attr_o_ar(a, s) result(c) &
bind(c, name="get_attr")
use, intrinsic :: iso_c_binding, only: &
c_int, c_bool, c_char
implicit none
integer(kind=c_int), intent(in) :: a(..)
logical(kind=c_bool), value, intent(in) :: s
character(kind=c_char) :: c
end function attr_o_ar
end interface
integer(kind=c_int), target :: a(n)
integer(kind=c_int), allocatable, target :: b(:)
integer(kind=c_int), pointer :: p(:)
character(kind=c_char) :: c
a = u
c = attr_p_as(a, .true._c_bool)
if(c/='p') stop 1
if(any(a/=u)) stop 2
!
a = u
c = attr_p_ar(a, .true._c_bool)
if(c/='p') stop 3
if(any(a/=u)) stop 4
!
a = u
c = attr_o_as(a, .true._c_bool)
if(c/='o') stop 5
if(any(a/=u)) stop 6
!
a = u
c = attr_o_ar(a, .true._c_bool)
if(c/='o') stop 7
if(any(a/=u)) stop 8
!
allocate(b, source=u)
c = attr_p_as(b, .true._c_bool)
if(c/='p') stop 9
if(.not.allocated(b)) stop 10
if(any(b/=u)) stop 11
!
deallocate(b)
allocate(b, source=u)
c = attr_p_ar(b, .true._c_bool)
if(c/='p') stop 12
if(.not.allocated(b)) stop 13
if(any(b/=u)) stop 14
!
deallocate(b)
allocate(b, source=u)
c = attr_a_as(b, .true._c_bool)
if(c/='a') stop 15
if(.not.allocated(b)) stop 16
if(any(b/=u)) stop 17
!
deallocate(b)
allocate(b, source=u)
c = attr_a_ar(b, .true._c_bool)
if(c/='a') stop 18
if(.not.allocated(b)) stop 19
if(any(b/=u)) stop 20
!
deallocate(b)
allocate(b, source=u)
c = attr_o_as(b, .true._c_bool)
if(c/='o') stop 21
if(.not.allocated(b)) stop 22
if(any(b/=u)) stop 23
!
deallocate(b)
allocate(b, source=u)
c = attr_o_ar(b, .true._c_bool)
if(c/='o') stop 24
if(.not.allocated(b)) stop 25
if(any(b/=u)) stop 26
!
deallocate(b)
c = attr_a_as(b, .false._c_bool)
if(c/='a') stop 27
if(allocated(b)) stop 28
!
c = attr_a_ar(b, .false._c_bool)
if(c/='a') stop 29
if(allocated(b)) stop 30
!
nullify(p)
p => a
c = attr_p_as(p, .true._c_bool)
if(c/='p') stop 31
if(.not.associated(p)) stop 32
if(.not.associated(p, a)) stop 33
if(any(p/=u)) stop 34
!
nullify(p)
p => a
c = attr_p_ar(p, .true._c_bool)
if(c/='p') stop 35
if(.not.associated(p)) stop 36
if(.not.associated(p, a)) stop 37
if(any(p/=u)) stop 38
!
nullify(p)
p => a
c = attr_o_as(p, .true._c_bool)
if(c/='o') stop 39
if(.not.associated(p)) stop 40
if(.not.associated(p, a)) stop 41
if(any(p/=u)) stop 42
!
nullify(p)
p => a
c = attr_o_ar(p, .true._c_bool)
if(c/='o') stop 43
if(.not.associated(p)) stop 44
if(.not.associated(p, a)) stop 45
if(any(p/=u)) stop 46
!
nullify(p)
c = attr_p_as(p, .false._c_bool)
if(c/='p') stop 47
if(associated(p)) stop 48
if(associated(p, a)) stop 49
!
nullify(p)
c = attr_p_ar(p, .false._c_bool)
if(c/='p') stop 50
if(associated(p)) stop 51
if(associated(p, a)) stop 52
stop
end program attr_p

Fortran/gfortran/regression/PR94331.c

/* Test the fix for PR94331. */
#include <assert.h>
#include <stdbool.h>
#include <stdlib.h>
#include <ISO_Fortran_binding.h>
bool c_vrfy (const CFI_cdesc_t *restrict);
bool check_bounds(const CFI_cdesc_t*restrict, const int, const int);
bool
c_vrfy (const CFI_cdesc_t *restrict auxp)
{
CFI_index_t i, lb, ub, ex;
int *ip = NULL;
assert (auxp);
assert (auxp->base_addr);
lb = auxp->dim[0].lower_bound;
ex = auxp->dim[0].extent;
ub = ex + lb - 1;
ip = (int*)auxp->base_addr;
for (i=0; i<ex; i++)
if (*ip++ != i+1)
return false;
for (i=lb; i<ub+1; i++)
{
ip = (int*)CFI_address(auxp, &i);
if (*ip != i-lb+1)
return false;
}
return true;
}
bool
check_bounds (const CFI_cdesc_t *restrict auxp, const int lb, const int ub)
{
CFI_index_t ex = ub-lb+1;
size_t el;
bool is_ok = false;
assert (auxp);
el = auxp->elem_len;
assert (auxp->rank==1);
assert (auxp->type==CFI_type_int);
assert (auxp->dim[0].sm>0);
assert ((size_t)auxp->dim[0].sm==el);
if (auxp->dim[0].extent==ex
&& auxp->dim[0].lower_bound==lb)
{
switch(auxp->attribute)
{
case CFI_attribute_pointer:
case CFI_attribute_allocatable:
if (!c_vrfy (auxp))
break;
is_ok = true;
break;
case CFI_attribute_other:
if (!c_vrfy (auxp))
break;
is_ok = (lb==0);
break;
default:
assert (false);
break;
}
}
return is_ok;
}

Fortran/gfortran/regression/PR94331.f90

! { dg-do run }
! { dg-additional-sources PR94331.c }
!
! Test the fix for PR94331
!
program main_p
use, intrinsic :: iso_c_binding, only: &
c_int
implicit none
integer :: i
integer, parameter :: ex = 11
integer, parameter :: lb = 11
integer, parameter :: ub = ex+lb-1
integer, parameter :: u(*) = [(i, i=1,ex)]
interface
function checkb_p_as(a, l, u) result(c) &
bind(c, name="check_bounds")
use, intrinsic :: iso_c_binding, only: &
c_int, c_bool
implicit none
integer(kind=c_int), pointer, intent(in) :: a(:)
integer(kind=c_int), value, intent(in) :: l
integer(kind=c_int), value, intent(in) :: u
logical(kind=c_bool) :: c
end function checkb_p_as
function checkb_a_as(a, l, u) result(c) &
bind(c, name="check_bounds")
use, intrinsic :: iso_c_binding, only: &
c_int, c_bool
implicit none
integer(kind=c_int), allocatable, intent(in) :: a(:)
integer(kind=c_int), value, intent(in) :: l
integer(kind=c_int), value, intent(in) :: u
logical(kind=c_bool) :: c
end function checkb_a_as
function checkb_o_as(a, l, u) result(c) &
bind(c, name="check_bounds")
use, intrinsic :: iso_c_binding, only: &
c_int, c_bool
implicit none
integer(kind=c_int), intent(in) :: a(:)
integer(kind=c_int), value, intent(in) :: l
integer(kind=c_int), value, intent(in) :: u
logical(kind=c_bool) :: c
end function checkb_o_as
function checkb_p_ar(a, l, u) result(c) &
bind(c, name="check_bounds")
use, intrinsic :: iso_c_binding, only: &
c_int, c_bool
implicit none
integer(kind=c_int), pointer, intent(in) :: a(..)
integer(kind=c_int), value, intent(in) :: l
integer(kind=c_int), value, intent(in) :: u
logical(kind=c_bool) :: c
end function checkb_p_ar
function checkb_a_ar(a, l, u) result(c) &
bind(c, name="check_bounds")
use, intrinsic :: iso_c_binding, only: &
c_int, c_bool
implicit none
integer(kind=c_int), allocatable, intent(in) :: a(..)
integer(kind=c_int), value, intent(in) :: l
integer(kind=c_int), value, intent(in) :: u
logical(kind=c_bool) :: c
end function checkb_a_ar
function checkb_o_ar(a, l, u) result(c) &
bind(c, name="check_bounds")
use, intrinsic :: iso_c_binding, only: &
c_int, c_bool
implicit none
integer(kind=c_int), intent(in) :: a(..)
integer(kind=c_int), value, intent(in) :: l
integer(kind=c_int), value, intent(in) :: u
logical(kind=c_bool) :: c
end function checkb_o_ar
end interface
integer(kind=c_int), target :: a(lb:ub)
integer(kind=c_int), allocatable, target :: b(:)
integer(kind=c_int), pointer :: p(:)
a = u
if(lbound(a,1)/=lb) stop 1
if(ubound(a,1)/=ub) stop 2
if(any(shape(a)/=[ex])) stop 3
if(.not.checkb_p_as(a, lb, ub)) stop 4
if(lbound(a,1)/=lb) stop 5
if(ubound(a,1)/=ub) stop 6
if(any(shape(a)/=[ex])) stop 7
if(any(a/=u)) stop 8
!
a = u
if(lbound(a,1)/=lb) stop 9
if(ubound(a,1)/=ub) stop 10
if(any(shape(a)/=[ex])) stop 11
if(.not.checkb_p_ar(a, lb, ub)) stop 12
if(lbound(a,1)/=lb) stop 13
if(ubound(a,1)/=ub) stop 14
if(any(shape(a)/=[ex])) stop 15
if(any(a/=u)) stop 16
!
a = u
if(lbound(a,1)/=lb) stop 17
if(ubound(a,1)/=ub) stop 18
if(any(shape(a)/=[ex])) stop 19
if(.not.checkb_o_as(a, 0, ex-1))stop 20
if(lbound(a,1)/=lb) stop 21
if(ubound(a,1)/=ub) stop 22
if(any(shape(a)/=[ex])) stop 23
if(any(a/=u)) stop 24
!
a = u
if(lbound(a,1)/=lb) stop 25
if(ubound(a,1)/=ub) stop 26
if(any(shape(a)/=[ex])) stop 27
if(.not.checkb_o_ar(a, 0, ex-1))stop 28
if(lbound(a,1)/=lb) stop 29
if(ubound(a,1)/=ub) stop 30
if(any(shape(a)/=[ex])) stop 31
if(any(a/=u)) stop 32
!
allocate(b(lb:ub), source=u)
if(lbound(b,1)/=lb) stop 33
if(ubound(b,1)/=ub) stop 34
if(any(shape(b)/=[ex])) stop 35
if(.not.checkb_p_as(b, lb, ub)) stop 36
if(.not.allocated(b)) stop 37
if(lbound(b,1)/=lb) stop 38
if(ubound(b,1)/=ub) stop 39
if(any(shape(b)/=[ex])) stop 40
if(any(b/=u)) stop 41
!
deallocate(b)
allocate(b(lb:ub), source=u)
if(lbound(b,1)/=lb) stop 42
if(ubound(b,1)/=ub) stop 43
if(any(shape(b)/=[ex])) stop 44
if(.not.checkb_p_ar(b, lb, ub)) stop 45
if(.not.allocated(b)) stop 46
if(lbound(b,1)/=lb) stop 47
if(ubound(b,1)/=ub) stop 48
if(any(shape(b)/=[ex])) stop 49
if(any(b/=u)) stop 50
!
deallocate(b)
allocate(b(lb:ub), source=u)
if(lbound(b,1)/=lb) stop 51
if(ubound(b,1)/=ub) stop 52
if(any(shape(b)/=[ex])) stop 53
if(.not.checkb_a_as(b, lb, ub)) stop 54
if(.not.allocated(b)) stop 55
if(lbound(b,1)/=lb) stop 56
if(ubound(b,1)/=ub) stop 57
if(any(shape(b)/=[ex])) stop 58
if(any(b/=u)) stop 59
!
deallocate(b)
allocate(b(lb:ub), source=u)
if(lbound(b,1)/=lb) stop 60
if(ubound(b,1)/=ub) stop 61
if(any(shape(b)/=[ex])) stop 62
if(.not.checkb_a_ar(b, lb, ub)) stop 63
if(.not.allocated(b)) stop 64
if(lbound(b,1)/=lb) stop 65
if(ubound(b,1)/=ub) stop 66
if(any(shape(b)/=[ex])) stop 67
if(any(b/=u)) stop 68
!
deallocate(b)
allocate(b(lb:ub), source=u)
if(lbound(b,1)/=lb) stop 69
if(ubound(b,1)/=ub) stop 70
if(any(shape(b)/=[ex])) stop 71
if(.not.checkb_o_as(b, 0, ex-1))stop 72
if(.not.allocated(b)) stop 73
if(lbound(b,1)/=lb) stop 74
if(ubound(b,1)/=ub) stop 75
if(any(shape(b)/=[ex])) stop 76
if(any(b/=u)) stop 77
!
deallocate(b)
allocate(b(lb:ub), source=u)
if(lbound(b,1)/=lb) stop 78
if(ubound(b,1)/=ub) stop 79
if(any(shape(b)/=[ex])) stop 80
if(.not.checkb_o_ar(b, 0, ex-1))stop 81
if(.not.allocated(b)) stop 82
if(lbound(b,1)/=lb) stop 83
if(ubound(b,1)/=ub) stop 84
if(any(shape(b)/=[ex])) stop 85
if(any(b/=u)) stop 86
deallocate(b)
!
p(lb:ub) => a
if(lbound(p,1)/=lb) stop 87
if(ubound(p,1)/=ub) stop 88
if(any(shape(p)/=[ex])) stop 89
if(.not.checkb_p_as(p, lb, ub)) stop 90
if(.not.associated(p)) stop 91
if(.not.associated(p, a)) stop 92
if(lbound(p,1)/=lb) stop 93
if(ubound(p,1)/=ub) stop 94
if(any(shape(p)/=[ex])) stop 95
if(any(p/=u)) stop 96
!
nullify(p)
p(lb:ub) => a
if(lbound(p,1)/=lb) stop 97
if(ubound(p,1)/=ub) stop 98
if(any(shape(p)/=[ex])) stop 99
if(.not.checkb_p_ar(p, lb, ub)) stop 100
if(.not.associated(p)) stop 101
if(.not.associated(p, a)) stop 102
if(lbound(p,1)/=lb) stop 103
if(ubound(p,1)/=ub) stop 104
if(any(shape(p)/=[ex])) stop 105
if(any(p/=u)) stop 106
!
nullify(p)
p(lb:ub) => a
if(lbound(p,1)/=lb) stop 107
if(ubound(p,1)/=ub) stop 108
if(any(shape(p)/=[ex])) stop 109
if(.not.checkb_o_as(p, 0, ex-1))stop 110
if(.not.associated(p)) stop 111
if(.not.associated(p, a)) stop 112
if(lbound(p,1)/=lb) stop 113
if(ubound(p,1)/=ub) stop 114
if(any(shape(p)/=[ex])) stop 115
if(any(p/=u)) stop 116
!
nullify(p)
p(lb:ub) => a
if(lbound(p,1)/=lb) stop 117
if(ubound(p,1)/=ub) stop 118
if(any(shape(p)/=[ex])) stop 119
if(.not.checkb_o_ar(p, 0, ex-1))stop 120
if(.not.associated(p)) stop 121
if(.not.associated(p, a)) stop 122
if(lbound(p,1)/=lb) stop 123
if(ubound(p,1)/=ub) stop 124
if(any(shape(p)/=[ex])) stop 125
if(any(p/=u)) stop 126
nullify(p)
stop
end program main_p

Fortran/gfortran/regression/PR95196.f90

! { dg-do run }
program rnk_p
implicit none
integer, parameter :: n = 10
integer, parameter :: m = 5
integer, parameter :: s = 4
integer, parameter :: l = 4
integer, parameter :: u = s+l-1
integer :: a(n)
integer :: b(n,n)
integer :: c(n,n,n)
integer :: r(s*s*s)
integer :: i
a = reshape([(i, i=1,n)], [n])
b = reshape([(i, i=1,n*n)], [n,n])
c = reshape([(i, i=1,n*n*n)], [n,n,n])
r(1:s) = a(l:u)
call rnk_s(a(l:u), r(1:s))
r(1:s*s) = reshape(b(l:u,l:u), [s*s])
call rnk_s(b(l:u,l:u), r(1:s*s))
r = reshape(c(l:u,l:u,l:u), [s*s*s])
call rnk_s(c(l:u,l:7,l:u), r)
stop
contains
subroutine rnk_s(a, b)
integer, intent(in) :: a(..)
integer, intent(in) :: b(:)
!integer :: l(rank(a)), u(rank(a)) does not work due to Bug 94048
integer, allocatable :: lb(:), ub(:)
integer :: i, j, k, l
lb = lbound(a)
ub = ubound(a)
select rank(a)
rank(1)
if(any(lb/=lbound(a))) stop 11
if(any(ub/=ubound(a))) stop 12
if(size(a)/=size(b)) stop 13
do i = 1, size(a)
if(a(i)/=b(i)) stop 14
end do
rank(2)
if(any(lb/=lbound(a))) stop 21
if(any(ub/=ubound(a))) stop 22
if(size(a)/=size(b)) stop 23
k = 0
do j = 1, size(a, dim=2)
do i = 1, size(a, dim=1)
k = k + 1
if(a(i,j)/=b(k)) stop 24
end do
end do
rank(3)
if(any(lb/=lbound(a))) stop 31
if(any(ub/=ubound(a))) stop 32
if(size(a)/=size(b)) stop 33
l = 0
do k = 1, size(a, dim=3)
do j = 1, size(a, dim=2)
do i = 1, size(a, dim=1)
l = l + 1
! print *, a(i,j,k), b(l)
if(a(i,j,k)/=b(l)) stop 34
end do
end do
end do
rank default
stop 171
end select
deallocate(lb, ub)
return
end subroutine rnk_s
end program rnk_p

Fortran/gfortran/regression/PR95214.f90

! { dg-do run }
!
! PR fortran/95214
!
program chr_p
implicit none
integer, parameter :: u = 65
integer, parameter :: n = 26
character :: c(n)
integer :: i
c = [(achar(i), i=u,u+n-1)]
call chr_s(c, c)
call gfc_descriptor_c_char(c)
call s1(c)
call s1s_a(c)
call s1s_b(c)
call s2(c)
stop
contains
subroutine chr_s(a, b)
character, intent(in) :: a(..)
character, intent(in) :: b(:)
integer :: i
select rank(a)
rank(1)
do i = 1, size(a)
if(a(i)/=b(i)) stop 1
end do
rank default
stop 2
end select
return
end subroutine chr_s
! From Bug 66833
! Contributed by Damian Rouson <damian@sourceryinstitute.org>
subroutine gfc_descriptor_c_char(a)
character a(..)
if(rank(a)/=1) stop 3 ! ICE (also for lbound, ubound, and c_loc)
end subroutine gfc_descriptor_c_char
! From Bug 67938
! Contributed by Gerhard Steinmetz <gerhard.steinmetz.fortran@t-online.de>
! example z1.f90
subroutine s1(x)
character(1) :: x(..)
if(any(lbound(x)/=[1])) stop 4
if(any(ubound(x)/=[n])) stop 5
end subroutine s1
! example z1s.f90
subroutine s1s_a(x)
character :: x(..)
if(size(x)/=n) stop 6
end subroutine s1s_a
subroutine s1s_b(x)
character(77) :: x(..)
if(size(x)/=n) stop 7
end subroutine s1s_b
! example z2.f90
subroutine s2(x)
character(1) :: x(..)
if(lbound(x, dim=1)/=1) stop 8
if(ubound(x, dim=1)/=n) stop 9
if(size(x, dim=1)/=n) stop 10
end subroutine s2
end program chr_p

Fortran/gfortran/regression/PR95331.f90

! { dg-do run }
!
! PR fortran/95331
!
program main_p
implicit none
integer, parameter :: n = 10
integer, parameter :: m = 5
integer, parameter :: b = 3
integer, parameter :: t = n+b-1
integer, parameter :: l = 4
integer, parameter :: u = 7
integer, parameter :: s = 3
integer, parameter :: e = (u-l)/s+1
call test_f()
call test_s()
call test_p()
call test_a()
stop
contains
subroutine test_f()
integer :: x(n,n)
integer :: y(b:t)
integer :: i
x = reshape([(i, i=1,n*n)], [n,n])
y = x(:,m)
call sub_s(x(:,m), y, n)
call sub_s(y, x(:,m), n)
return
end subroutine test_f
subroutine test_s()
integer :: x(n,n)
integer :: v(e)
integer :: i
x = reshape([(i, i=1,n*n)], [n,n])
v = x(l:u:s,m)
call sub_s(v, v, e)
call sub_s(x(l:u:s,m), v, e)
call sub_s(v, x(l:u:s,m), e)
return
end subroutine test_s
subroutine test_p()
integer, target :: x(n,n)
integer, pointer :: p(:)
integer :: v(e)
integer :: i
x = reshape([(i, i=1,n*n)], [n,n])
v = x(l:u:s,m)
p => x(:,m)
call sub_s(p(l:u:s), v, e)
p => x(l:u:s,m)
call sub_s(p, v, e)
p(l:) => x(l:u:s,m)
call sub_s(p, v, e)
p(l:l+e-1) => x(l:u:s,m)
call sub_s(p, v, e)
allocate(p(n))
p(:) = x(:,m)
call sub_s(p(l:u:s), v, e)
deallocate(p)
allocate(p(e))
p(:) = x(l:u:s,m)
call sub_s(p, v, e)
deallocate(p)
allocate(p(l:l+e-1))
p(:) = x(l:u:s,m)
call sub_s(p, v, e)
deallocate(p)
allocate(p(l:l+e-1))
p(l:) = x(l:u:s,m)
call sub_s(p, v, e)
deallocate(p)
allocate(p(l:l+e-1))
p(l:l+e-1) = x(l:u:s,m)
call sub_s(p, v, e)
deallocate(p)
return
end subroutine test_p
subroutine test_a()
integer :: x(n,n)
integer, allocatable :: a(:)
integer :: v(e)
integer :: i
x = reshape([(i, i=1,n*n)], [n,n])
v = x(l:u:s,m)
a = x(:,m)
call sub_s(a(l:u:s), v, e)
deallocate(a)
allocate(a(n))
a(:) = x(:,m)
call sub_s(a(l:u:s), v, e)
deallocate(a)
a = x(l:u:s,m)
call sub_s(a, v, e)
deallocate(a)
allocate(a(e))
a(:) = x(l:u:s,m)
call sub_s(a, v, e)
deallocate(a)
allocate(a(l:l+e-1))
a(:) = x(l:u:s,m)
call sub_s(a, v, e)
deallocate(a)
allocate(a(l:l+e-1))
a(l:) = x(l:u:s,m)
call sub_s(a, v, e)
deallocate(a)
allocate(a(l:l+e-1))
a(l:l+e-1) = x(l:u:s,m)
call sub_s(a, v, e)
deallocate(a)
return
end subroutine test_a
subroutine sub_s(a, b, n)
class(*), intent(in) :: a(:)
integer, intent(in) :: b(:)
integer, intent(in) :: n
integer :: i
if(lbound(a, dim=1)/=1) stop 1001
if(ubound(a, dim=1)/=n) stop 1002
if(any(shape(a)/=[n])) stop 1003
if(size(a, dim=1)/=n) stop 1004
if(size(a)/=size(b)) stop 1005
do i = 1, n
call vrfy(a(i), b(i))
end do
return
end subroutine sub_s
subroutine vrfy(a, b)
class(*), intent(in) :: a
integer, intent(in) :: b
select type (a)
type is (integer)
!print *, a, b
if(a/=b) stop 2001
class default
STOP 2002
end select
return
end subroutine vrfy
end program main_p

Fortran/gfortran/regression/PR95352.f90

! { dg-do compile }
!
! Test the fix for PR95352
!
module ice6_m
implicit none
contains
function ice6_s(a) result(ierr)
integer, intent(in) :: a(..)
integer :: ierr
integer :: lb
select rank(a)
rank(*)
lb = lbound(a, dim=1)
if(lbound(a, dim=1)/=lb) ierr = -1
end select
return
end function ice6_s
end module ice6_m

Fortran/gfortran/regression/PR96726.f90

! { dg-do run }
!
! Test the fix for PR96726
!
module cref_m
implicit none
private
public :: &
sizeish
contains
pure function sizeish(a) result(s)
integer, intent(in) :: a(..)
integer :: s
s = size(a)
return
end function sizeish
end module cref_m
program cref_p
use cref_m, only: &
sizeish
implicit none
integer :: i
integer, parameter :: n = 3
integer, parameter :: p(*) = [(i, i=1,n*n)]
integer :: a(n,n)
integer :: b(n*n)
a = reshape(p, shape=[n,n])
call isub_a(a, b)
if (any(b/=p)) stop 1
call isub_b(a, b)
if (any(b/=p)) stop 2
stop
contains
subroutine isub_a(a, b)
integer, intent(in) :: a(..)
integer, intent(out) :: b(size(a))
integer :: i
b = [(i, i=1,size(b))]
return
end subroutine isub_a
subroutine isub_b(a, b)
integer, intent(in) :: a(..)
integer, intent(out) :: b(sizeish(a))
integer :: i
b = [(i, i=1,sizeish(b))]
return
end subroutine isub_b
end program cref_p

Fortran/gfortran/regression/PR96727.f90

! { dg-do run }
!
! Test the fix for PR96727
!
program cref_p
implicit none
integer :: i
integer, parameter :: n = 3
integer, parameter :: p(*) = [(i, i=1,n*n)]
character(len=*), parameter :: q = repeat('a', n*n)
integer :: a(n,n)
character(len=n*n) :: c
a = reshape(p, shape=[n,n])
call csub(a, c)
if (c/=q) stop 1
stop
contains
subroutine csub(a, b)
integer, intent(in) :: a(..)
character(len=size(a)), intent(out) :: b
b = repeat('a', len(b))
return
end subroutine csub
end program cref_p

Fortran/gfortran/regression/PR96728.f90

! { dg-do run }
!
! Test the fix for PR96728
!
module cref_m
implicit none
private
public :: &
isub_a_m
contains
subroutine isub_a_m(a, b)
integer, intent(in) :: a(..)
integer, intent(out) :: b(size(a))
integer :: i
b = [(i, i=1,size(b))]
return
end subroutine isub_a_m
end module cref_m
program cref_p
use cref_m, only: &
isub_a_m
implicit none
integer :: i
integer, parameter :: n = 3
integer, parameter :: p(*) = [(i, i=1,n*n)]
integer :: a(n,n)
integer :: b(n*n)
a = reshape(p, shape=[n,n])
call isub_a_m(a, b)
if (any(b/=p)) stop 1
stop
end program cref_p

Fortran/gfortran/regression/PR97046.f90

! { dg-do run }
!
! Test the fix for PR94331
!
! Contributed by Igor Gayday <igor.gayday@mu.edu>
!
MODULE FOO
implicit none
INTEGER, parameter :: n = 11
contains
SUBROUTINE dummyc(x0) BIND(C)
type(*), dimension(..) :: x0
if(LBOUND(x0,1)/=1) stop 5
if(UBOUND(x0,1)/=n) stop 6
if(rank(x0)/=1) stop 7
END SUBROUTINE dummyc
SUBROUTINE dummy(x0)
type(*), dimension(..) :: x0
call dummyc(x0)
END SUBROUTINE dummy
END MODULE
PROGRAM main
USE FOO
IMPLICIT NONE
integer :: before(2), after(2)
DOUBLE PRECISION, ALLOCATABLE :: buf(:)
DOUBLE PRECISION :: buf2(n)
ALLOCATE(buf(n))
before(1) = LBOUND(buf,1)
before(2) = UBOUND(buf,1)
CALL dummy (buf)
after(1) = LBOUND(buf,1)
after(2) = UBOUND(buf,1)
deallocate(buf)
if (before(1) .NE. after(1)) stop 1
if (before(2) .NE. after(2)) stop 2
before(1) = LBOUND(buf2,1)
before(2) = UBOUND(buf2,1)
CALL dummy (buf2)
after(1) = LBOUND(buf2,1)
after(2) = UBOUND(buf2,1)
if (before(1) .NE. after(1)) stop 3
if (before(2) .NE. after(2)) stop 4
END PROGRAM

Fortran/gfortran/regression/Wall.f90

! { dg-do run }
! { dg-options -Wall }
! PR 30437 Test for Wall
program main
character (len=40) &
c
c = "Hello, &
world!" ! { dg-warning "Missing '&' in continued character constant" }
if (c.ne.&
"Hello, world!")&
STOP 1;end program main

Fortran/gfortran/regression/Wno-all.f90

! PR 30437 Test for negative Wall
! { dg-do run }
! { dg-options "-Wall -Wno-all" }
program main
character (len=40) &
c
c = "Hello, &
world!" ! { dg-bogus "Warning: Missing '&' in continued character constant" }
if (c.ne.&
"Hello, world!")&
STOP 1;end program main