C Descriptors and ISO_Fortran_binding

#include <stdio.h>
#include <ISO_Fortran_binding.h>

static const char *attribute_name(CFI_attribute_t a)
{
    if (a == CFI_attribute_pointer) return "pointer";
    if (a == CFI_attribute_allocatable) return "allocatable";
    if (a == CFI_attribute_other) return "other";
    return "unknown";
}

void describe(const CFI_cdesc_t *d)
{
    printf("  rank=%d elem_len=%zu attribute=%s double=%s\n", (int)d->rank, d->elem_len,
           attribute_name(d->attribute), d->type == CFI_type_double ? "yes" : "no");
    for (int i = 0; i < d->rank; i++)
        printf("  dim[%d]: lower_bound=%ld extent=%ld sm=%ld\n", i, (long)d->dim[i].lower_bound,
               (long)d->dim[i].extent, (long)d->dim[i].sm);
    printf("  contiguous=%d\n", CFI_is_contiguous(d));
    fflush(stdout);
}

module descr_api
    use, intrinsic :: iso_c_binding, only: c_double
    implicit none
    interface
        subroutine describe(u) bind(c, name='describe')
            import :: c_double
            real(c_double), intent(in) :: u(:, :)
        end subroutine describe
    end interface
end module descr_api

program describe_demo
    use, intrinsic :: iso_c_binding, only: c_double
    use, intrinsic :: iso_fortran_env, only: output_unit
    use descr_api, only: describe
    implicit none
    integer, parameter :: nx = 4, ny = 6
    real(c_double), target :: u(nx, ny)
    real(c_double) :: v(0:3, -1:1)
    integer :: i, j

    u = reshape([((real(10 * i + j, c_double), i = 1, nx), j = 1, ny)], [nx, ny])
    v = 0.0_c_double

    print '(a)', 'whole array u(1:4, 1:6):'
    flush (output_unit)
    call describe(u)

    print '(a)', 'section u(2:4, 2:6:2):'
    flush (output_unit)
    call describe(u(2:4, 2:6:2))

    print '(a)', 'column block u(:, 5:6):'
    flush (output_unit)
    call describe(u(:, 5:6))

    print '(a)', 'array v(0:3, -1:1) declared with other lower bounds:'
    flush (output_unit)
    call describe(v)
end program describe_demo

whole array u(1:4, 1:6):
  rank=2 elem_len=8 attribute=other double=yes
  dim[0]: lower_bound=0 extent=4 sm=8
  dim[1]: lower_bound=0 extent=6 sm=32
  contiguous=1
section u(2:4, 2:6:2):
  rank=2 elem_len=8 attribute=other double=yes
  dim[0]: lower_bound=0 extent=3 sm=8
  dim[1]: lower_bound=0 extent=3 sm=64
  contiguous=0
column block u(:, 5:6):
  rank=2 elem_len=8 attribute=other double=yes
  dim[0]: lower_bound=0 extent=4 sm=8
  dim[1]: lower_bound=0 extent=2 sm=32
  contiguous=1
array v(0:3, -1:1) declared with other lower bounds:
  rank=2 elem_len=8 attribute=other double=yes
  dim[0]: lower_bound=0 extent=4 sm=8
  dim[1]: lower_bound=0 extent=3 sm=32
  contiguous=1

#include <stdio.h>
#include <ISO_Fortran_binding.h>

/* A fast path that is only correct for contiguous data: it walks base_addr with unit stride. */
static double sum_fast(const CFI_cdesc_t *x)
{
    const double *p = x->base_addr;
    double s = 0.0;
    printf("  C: extent=%ld sm=%ld contiguous=%d\n", (long)x->dim[0].extent, (long)x->dim[0].sm,
           CFI_is_contiguous(x));
    fflush(stdout);
    for (CFI_index_t i = 0; i < x->dim[0].extent; i++)
        s += p[i];
    return s;
}

/* Two entry points so that each Fortran interface body has its own binding label. */
double sum_fast_plain(const CFI_cdesc_t *x) { return sum_fast(x); }
double sum_fast_contig(const CFI_cdesc_t *x) { return sum_fast(x); }

program contiguous_c_side
    use, intrinsic :: iso_c_binding, only: c_double
    use, intrinsic :: iso_fortran_env, only: output_unit
    implicit none
    interface
        function sum_fast_plain(x) result(s) bind(c, name='sum_fast_plain')
            import :: c_double
            real(c_double), intent(in) :: x(:)
            real(c_double) :: s
        end function sum_fast_plain
        function sum_fast_contig(x) result(s) bind(c, name='sum_fast_contig')
            import :: c_double
            real(c_double), contiguous, intent(in) :: x(:)
            real(c_double) :: s
        end function sum_fast_contig
    end interface
    real(c_double) :: a(10), s
    integer :: i

    a = [(real(i, c_double), i = 1, 10)]
    print '(a, f6.1)', 'Fortran sum(a(1:10:2)) =', sum(a(1:10:2))
    flush (output_unit)
    s = sum_fast_plain(a(1:10:2))
    print '(a, f6.1)', 'plain interface:      ', s
    flush (output_unit)
    s = sum_fast_contig(a(1:10:2))
    print '(a, f6.1)', 'contiguous interface: ', s
end program contiguous_c_side

Fortran sum(a(1:10:2)) =  25.0
  C: extent=5 sm=16 contiguous=0
plain interface:        15.0
  C: extent=5 sm=8 contiguous=1
contiguous interface:   25.0

#include <ISO_Fortran_binding.h>

/* Allocate an nx-by-ny allocatable array of double with lower bounds 1 and
   fill it with a uniform temperature. */
int make_field(CFI_cdesc_t *u, int nx, int ny, double t0)
{
    CFI_index_t lower[2] = {1, 1};
    CFI_index_t upper[2] = {nx, ny};
    int stat = CFI_allocate(u, lower, upper, 0); /* elem_len is ignored for non-character types */
    if (stat != CFI_SUCCESS)
        return stat;
    for (CFI_index_t j = 0; j < ny; j++)
        for (CFI_index_t i = 0; i < nx; i++) {
            CFI_index_t sub[2] = {1 + i, 1 + j};
            *(double *)CFI_address(u, sub) = t0 + 0.5 * (double)(i + j);
        }
    return CFI_SUCCESS;
}

/* Free it again; the descriptor's base_addr becomes NULL. */
int release_field(CFI_cdesc_t *u)
{
    return CFI_deallocate(u);
}

module descr_alloc
    use, intrinsic :: iso_c_binding, only: c_double, c_int
    implicit none
    interface
        function make_field(u, nx, ny, t0) result(stat) bind(c, name='make_field')
            import :: c_double, c_int
            real(c_double), allocatable, intent(out) :: u(:, :)
            integer(c_int), value :: nx, ny
            real(c_double), value :: t0
            integer(c_int) :: stat
        end function make_field
        function release_field(u) result(stat) bind(c, name='release_field')
            import :: c_double, c_int
            real(c_double), allocatable, intent(inout) :: u(:, :)
            integer(c_int) :: stat
        end function release_field
    end interface
end module descr_alloc

program alloc_demo
    use, intrinsic :: iso_c_binding, only: c_double, c_int
    use descr_alloc, only: make_field, release_field
    implicit none
    real(c_double), allocatable :: u(:, :)
    integer(c_int) :: stat

    stat = make_field(u, 4_c_int, 3_c_int, 20.0_c_double)
    print '(a, i0, a, l1)', 'make_field:    stat=', stat, ' allocated=', allocated(u)
    print '(a, 2i3, a, 2i3)', 'shape and lower bounds:', shape(u), '  /', lbound(u)
    print '(a, f6.2, a, f6.2)', 'u(1,1)=', u(1, 1), '  u(4,3)=', u(4, 3)

    stat = release_field(u)
    print '(a, i0, a, l1)', 'release_field: stat=', stat, ' allocated=', allocated(u)
end program alloc_demo

make_field:    stat=0 allocated=T
shape and lower bounds:  4  3  /  1  1
u(1,1)= 20.00  u(4,3)= 22.50
release_field: stat=0 allocated=F

#include <ISO_Fortran_binding.h>

/* Point p at the interior window u(i1:i2, j1:j2) of the whole array u, using
   Fortran (1-based) subscripts. u must have the target attribute in the caller. */
int window(CFI_cdesc_t *p, const CFI_cdesc_t *u, int i1, int i2, int j1, int j2)
{
    CFI_CDESC_T(2) section;
    CFI_cdesc_t *s = (CFI_cdesc_t *)&section;
    CFI_index_t lower[2], upper[2];
    CFI_index_t new_lower[2] = {1, 1};
    CFI_index_t strides[2] = {1, 1};   /* the pointer's own lower bounds */
    int stat;

    /* A descriptor for a nonallocatable array always has lower bounds 0. */
    lower[0] = i1 - 1 + u->dim[0].lower_bound;
    upper[0] = i2 - 1 + u->dim[0].lower_bound;
    lower[1] = j1 - 1 + u->dim[1].lower_bound;
    upper[1] = j2 - 1 + u->dim[1].lower_bound;

    stat = CFI_establish(s, NULL, CFI_attribute_other, CFI_type_double, sizeof(double), 2, NULL);
    if (stat != CFI_SUCCESS)
        return stat;
    stat = CFI_section(s, u, lower, upper, strides);   /* see below: pass strides explicitly */
    if (stat != CFI_SUCCESS)
        return stat;
    return CFI_setpointer(p, s, new_lower);          /* p now describes the section */
}

/* Disassociate the pointer. */
int unlink_window(CFI_cdesc_t *p)
{
    return CFI_setpointer(p, NULL, NULL);
}

module descr_window
    use, intrinsic :: iso_c_binding, only: c_double, c_int
    implicit none
    interface
        function window(p, u, i1, i2, j1, j2) result(stat) bind(c, name='window')
            import :: c_double, c_int
            real(c_double), pointer, intent(out) :: p(:, :)
            real(c_double), target, intent(in) :: u(:, :)
            integer(c_int), value :: i1, i2, j1, j2
            integer(c_int) :: stat
        end function window
        function unlink_window(p) result(stat) bind(c, name='unlink_window')
            import :: c_double, c_int
            real(c_double), pointer, intent(inout) :: p(:, :)
            integer(c_int) :: stat
        end function unlink_window
    end interface
end module descr_window

program window_demo
    use, intrinsic :: iso_c_binding, only: c_double, c_int
    use descr_window, only: window, unlink_window
    implicit none
    integer, parameter :: nx = 6, ny = 5
    real(c_double), target :: u(nx, ny)
    real(c_double), pointer :: p(:, :)
    integer(c_int) :: stat

    u = 0.0_c_double
    p => null()
    stat = window(p, u, 2_c_int, 5_c_int, 2_c_int, 4_c_int)
    print '(a, i0, a, l1)', 'window:        stat=', stat, ' associated=', associated(p)
    print '(a, 2i3, a, 2i3, a, 2i3)', 'shape:', shape(p), '  lbound:', lbound(p), '  ubound:', ubound(p)

    p = 100.0_c_double                  ! writes through the pointer into u
    print '(a, 6f6.1)', 'u(:, 1) =', u(:, 1)
    print '(a, 6f6.1)', 'u(:, 2) =', u(:, 2)
    print '(a, 6f6.1)', 'u(:, 5) =', u(:, 5)
    u(2, 2) = -1.0_c_double
    print '(a, f6.1)', 'p(1, 1) after u(2, 2) = -1:', p(1, 1)

    stat = unlink_window(p)
    print '(a, i0, a, l1)', 'unlink_window: stat=', stat, ' associated=', associated(p)
end program window_demo

window:        stat=0 associated=T
shape:  4  3  lbound:  1  1  ubound:  4  3
u(:, 1) =   0.0   0.0   0.0   0.0   0.0   0.0
u(:, 2) =   0.0 100.0 100.0 100.0 100.0   0.0
u(:, 5) =   0.0   0.0   0.0   0.0   0.0   0.0
p(1, 1) after u(2, 2) = -1:  -1.0
unlink_window: stat=0 associated=F

#include <stddef.h>
#include <ISO_Fortran_binding.h>

typedef struct {
    int id;
    double t;
} probe_t;

/* Scale the temperature component of every probe by "factor" without touching the ids:
   describe the array of the t components and write through it. Returns the sum of the new values. */
int scale_probes(const CFI_cdesc_t *probes, double factor, double *total)
{
    CFI_CDESC_T(1) comp;
    CFI_cdesc_t *c = (CFI_cdesc_t *)&comp;
    CFI_index_t extent[1];
    int stat;

    if (probes->type != CFI_type_struct)
        return CFI_INVALID_TYPE;
    extent[0] = probes->dim[0].extent;
    stat = CFI_establish(c, NULL, CFI_attribute_other, CFI_type_double, sizeof(double), 1, extent);
    if (stat != CFI_SUCCESS)
        return stat;
    stat = CFI_select_part(c, probes, offsetof(probe_t, t), 0);
    if (stat != CFI_SUCCESS)
        return stat;
    *total = 0.0;
    for (CFI_index_t i = 0; i < c->dim[0].extent; i++) {
        CFI_index_t sub[1] = {c->dim[0].lower_bound + i};
        double *t = CFI_address(c, sub);
        *t *= factor;
        *total += *t;
    }
    return CFI_SUCCESS;
}

module descr_probes
    use, intrinsic :: iso_c_binding, only: c_double, c_int
    implicit none
    type, bind(c) :: probe_t
        integer(c_int) :: id
        real(c_double) :: t
    end type probe_t
    interface
        function scale_probes(probes, factor, total) result(stat) bind(c, name='scale_probes')
            import :: probe_t, c_double, c_int
            type(probe_t), intent(inout) :: probes(:)
            real(c_double), value :: factor
            real(c_double), intent(out) :: total
            integer(c_int) :: stat
        end function scale_probes
    end interface
end module descr_probes

program probes_demo
    use, intrinsic :: iso_c_binding, only: c_double, c_int
    use descr_probes, only: probe_t, scale_probes
    implicit none
    type(probe_t) :: probes(6)
    real(c_double) :: total
    integer(c_int) :: stat
    integer :: i

    probes = [(probe_t(id=i, t=10.0_c_double * i), i = 1, 6)]
    stat = scale_probes(probes(2:6:2), 0.5_c_double, total)
    print '(a, i0, a, f6.1)', 'stat=', stat, '  total of the new values=', total
    print '(a, 6i5)', 'ids:', probes%id
    print '(a, 6f5.1)', 't:  ', probes%t
end program probes_demo

stat=0  total of the new values=  60.0
ids:    1    2    3    4    5    6
t:   10.0 10.0 30.0 20.0 50.0 30.0

#include <stdio.h>
#include <ISO_Fortran_binding.h>

/* A Fortran character(len=*) dummy arrives as a rank-0 descriptor whose elem_len is the length. */
int show_name(const CFI_cdesc_t *s)
{
    if (s->type != CFI_type_char)
        return CFI_INVALID_TYPE;
    printf("rank=%d elem_len=%zu text=[%.*s]\n", (int)s->rank, s->elem_len, (int)s->elem_len,
           (const char *)s->base_addr);
    fflush(stdout);
    return CFI_SUCCESS;
}

program character_descriptor
    use, intrinsic :: iso_c_binding, only: c_char, c_int
    implicit none
    interface
        function show_name(s) result(stat) bind(c, name='show_name')
            import :: c_char, c_int
            character(kind=c_char, len=*), intent(in) :: s
            integer(c_int) :: stat
        end function show_name
    end interface
    character(kind=c_char, len=20) :: name = 'heatflow'
    integer(c_int) :: stat

    stat = show_name(name)
    stat = show_name(trim(name))
    stat = show_name(name(1:4))
end program character_descriptor

rank=0 elem_len=20 text=[heatflow            ]
rank=0 elem_len=8 text=[heatflow]
rank=0 elem_len=4 text=[heat]

module field_ops
    use, intrinsic :: iso_c_binding, only: c_double, c_int
    use, intrinsic :: iso_fortran_env, only: output_unit
    implicit none
contains
    ! Assumed-shape dummy: C must pass the address of a descriptor.
    subroutine scale_field(u, factor) bind(c, name='scale_field')
        real(c_double), intent(inout) :: u(:, :)
        real(c_double), value :: factor
        print '(a, 2i3, a, 2i3)', '  Fortran sees shape', shape(u), '  lbound', lbound(u)
        u = factor * u
        flush (output_unit)
    end subroutine scale_field

    ! Allocatable dummy: Fortran allocates, C owns the descriptor.
    subroutine fill_field(u, nx, ny) bind(c, name='fill_field')
        real(c_double), allocatable, intent(out) :: u(:, :)
        integer(c_int), value :: nx, ny
        integer :: i, j
        allocate (u(0:nx - 1, 0:ny - 1))
        do j = 0, ny - 1
            do i = 0, nx - 1
                u(i, j) = real(10 * i + j, c_double)
            end do
        end do
        print '(a, 2i3, a, 2i3)', '  Fortran allocated shape', shape(u), '  lbound', lbound(u)
        flush (output_unit)
    end subroutine fill_field
end module field_ops

#include <stdio.h>
#include <ISO_Fortran_binding.h>

void scale_field(const CFI_cdesc_t *u, double factor);   /* Fortran: u is intent(inout), so the descriptor is read-only */
void fill_field(CFI_cdesc_t *u, int nx, int ny);

int main(void)
{
    /* A C array: a[j][i] has i varying fastest, which is Fortran's u(i+1, j+1). */
    double a[3][4];
    for (int j = 0; j < 3; j++)
        for (int i = 0; i < 4; i++)
            a[j][i] = 10.0 * (i + 1) + (j + 1);

    /* 1. Describe a C array so that a Fortran assumed-shape dummy can receive it. */
    CFI_CDESC_T(2) whole;
    CFI_cdesc_t *w = (CFI_cdesc_t *)&whole;
    CFI_index_t extents[2] = {4, 3};                       /* extents in Fortran order: i, then j */
    int stat = CFI_establish(w, a, CFI_attribute_other, CFI_type_double, sizeof(double), 2, extents);
    printf("establish: stat=%d contiguous=%d sm=(%ld,%ld)\n", stat, CFI_is_contiguous(w),
           (long)w->dim[0].sm, (long)w->dim[1].sm);
    fflush(stdout);
    scale_field(w, 2.0);
    printf("a[0][0]=%.1f a[2][3]=%.1f\n", a[0][0], a[2][3]);

    /* 2. A strided section: every second column (j = 0 and 2), rows i = 1..3. */
    CFI_CDESC_T(2) part;
    CFI_cdesc_t *p = (CFI_cdesc_t *)&part;
    CFI_index_t lower[2] = {1, 0}, upper[2] = {3, 2}, strides[2] = {1, 2};
    stat = CFI_establish(p, NULL, CFI_attribute_other, CFI_type_double, sizeof(double), 2, NULL);
    stat |= CFI_section(p, w, lower, upper, strides);
    printf("section: stat=%d extents=(%ld,%ld) contiguous=%d\n", stat, (long)p->dim[0].extent,
           (long)p->dim[1].extent, CFI_is_contiguous(p));
    fflush(stdout);
    scale_field(p, 0.5);
    printf("a[0][0]=%.1f a[0][1]=%.1f a[1][1]=%.1f\n", a[0][0], a[0][1], a[1][1]);

    /* 3. An unallocated allocatable: Fortran allocates it, C reads it and frees it. */
    CFI_CDESC_T(2) field;
    CFI_cdesc_t *f = (CFI_cdesc_t *)&field;
    stat = CFI_establish(f, NULL, CFI_attribute_allocatable, CFI_type_double, sizeof(double), 2, NULL);
    printf("allocatable before: stat=%d base_addr=%s\n", stat, f->base_addr == NULL ? "NULL" : "set");
    fflush(stdout);
    fill_field(f, 3, 2);
    CFI_index_t sub[2] = {2, 1};
    printf("allocatable after: lower=(%ld,%ld) extent=(%ld,%ld) u(2,1)=%.1f\n", (long)f->dim[0].lower_bound,
           (long)f->dim[1].lower_bound, (long)f->dim[0].extent, (long)f->dim[1].extent,
           *(double *)CFI_address(f, sub));
    stat = CFI_deallocate(f);
    printf("deallocate: stat=%d base_addr=%s\n", stat, f->base_addr == NULL ? "NULL" : "set");
    return 0;
}

establish: stat=0 contiguous=1 sm=(8,32)
  Fortran sees shape  4  3  lbound  1  1
a[0][0]=22.0 a[2][3]=86.0
section: stat=0 extents=(3,2) contiguous=0
  Fortran sees shape  3  2  lbound  1  1
a[0][0]=22.0 a[0][1]=21.0 a[1][1]=44.0
allocatable before: stat=0 base_addr=NULL
  Fortran allocated shape  3  2  lbound  0  0
allocatable after: lower=(0,0) extent=(3,2) u(2,1)=21.0
deallocate: stat=0 base_addr=NULL

#include <stdio.h>
#include <ISO_Fortran_binding.h>

static const char *error_name(int e)
{
    if (e == CFI_SUCCESS) return "CFI_SUCCESS";
    if (e == CFI_ERROR_BASE_ADDR_NULL) return "CFI_ERROR_BASE_ADDR_NULL";
    if (e == CFI_ERROR_BASE_ADDR_NOT_NULL) return "CFI_ERROR_BASE_ADDR_NOT_NULL";
    if (e == CFI_INVALID_ELEM_LEN) return "CFI_INVALID_ELEM_LEN";
    if (e == CFI_INVALID_RANK) return "CFI_INVALID_RANK";
    if (e == CFI_INVALID_TYPE) return "CFI_INVALID_TYPE";
    if (e == CFI_INVALID_ATTRIBUTE) return "CFI_INVALID_ATTRIBUTE";
    if (e == CFI_INVALID_EXTENT) return "CFI_INVALID_EXTENT";
    if (e == CFI_INVALID_DESCRIPTOR) return "CFI_INVALID_DESCRIPTOR";
    if (e == CFI_ERROR_MEM_ALLOCATION) return "CFI_ERROR_MEM_ALLOCATION";
    if (e == CFI_ERROR_OUT_OF_BOUNDS) return "CFI_ERROR_OUT_OF_BOUNDS";
    return "(not a standard code)";
}

static void report(const char *what, int e)
{
    printf("%-52s -> %2d %s\n", what, e, error_name(e));
    fflush(stdout);
}

void run_errors(void)
{
    CFI_CDESC_T(CFI_MAX_RANK) store;
    CFI_cdesc_t *d = (CFI_cdesc_t *)&store;
    CFI_CDESC_T(2) res;
    CFI_cdesc_t *r = (CFI_cdesc_t *)&res;
    double x[6] = {0};
    CFI_index_t ext[2] = {2, 3}, neg[2] = {2, -3};

    printf("CFI_VERSION=%d CFI_MAX_RANK=%d\n", CFI_VERSION, CFI_MAX_RANK);
    printf("attributes: pointer=%d allocatable=%d other=%d\n", CFI_attribute_pointer,
           CFI_attribute_allocatable, CFI_attribute_other);
    printf("types: int=%ld long=%ld float=%ld double=%ld char=%ld cptr=%ld struct=%ld other=%ld\n",
           (long)CFI_type_int, (long)CFI_type_long, (long)CFI_type_float, (long)CFI_type_double,
           (long)CFI_type_char, (long)CFI_type_cptr, (long)CFI_type_struct, (long)CFI_type_other);

    report("establish, rank CFI_MAX_RANK+1",
           CFI_establish(d, x, CFI_attribute_other, CFI_type_double, 8, CFI_MAX_RANK + 1, ext));
    report("establish, attribute 99",
           CFI_establish(d, x, 99, CFI_type_double, 8, 2, ext));
    report("establish, type -100",
           CFI_establish(d, x, CFI_attribute_other, (CFI_type_t)-100, 8, 2, ext));
    report("establish, struct with elem_len 0",
           CFI_establish(d, x, CFI_attribute_other, CFI_type_struct, 0, 2, ext));
    report("establish, extent -3",
           CFI_establish(d, x, CFI_attribute_other, CFI_type_double, 8, 2, neg));
    report("establish, allocatable with a base address",
           CFI_establish(d, x, CFI_attribute_allocatable, CFI_type_double, 8, 2, ext));

    report("establish, unallocated allocatable",
           CFI_establish(d, NULL, CFI_attribute_allocatable, CFI_type_double, 8, 2, NULL));
    {
        CFI_index_t lo[2] = {1, 1}, up[2] = {2, 3};
        report("allocate, 2x3", CFI_allocate(d, lo, up, 0));
        report("allocate again, base address is not NULL", CFI_allocate(d, lo, up, 0));
    }
    report("deallocate", CFI_deallocate(d));
    report("deallocate again, base address is NULL", CFI_deallocate(d));
    {
        CFI_index_t lo[2] = {1, 1}, up[2] = {1000000000000000L, 1000000000000000L};
        report("allocate, absurd extents", CFI_allocate(d, lo, up, 0));
    }

    CFI_establish(d, x, CFI_attribute_other, CFI_type_double, 8, 2, ext);
    CFI_establish(r, NULL, CFI_attribute_other, CFI_type_double, 8, 2, NULL);
    {
        CFI_index_t lo[2] = {0, 0}, up[2] = {1, 3}, st[2] = {1, 1};
        report("section, upper bound 3 on an extent-3 dimension", CFI_section(r, d, lo, up, st));
        up[1] = 2;
        report("section, in bounds", CFI_section(r, d, lo, up, st));
    }
    report("setpointer, result is not a pointer", CFI_setpointer(r, d, NULL));

}

program errors_demo
    implicit none
    interface
        subroutine run_errors() bind(c, name='run_errors')
        end subroutine run_errors
    end interface
    call run_errors()
end program errors_demo

CFI_VERSION=1 CFI_MAX_RANK=15
attributes: pointer=0 allocatable=1 other=2
types: int=1025 long=2049 float=1027 double=2051 char=261 cptr=7 struct=6 other=-1
establish, rank CFI_MAX_RANK+1                       ->  5 CFI_INVALID_RANK
establish, attribute 99                              ->  0 CFI_SUCCESS
establish, type -100                                 ->  6 CFI_INVALID_TYPE
establish, struct with elem_len 0                    ->  4 CFI_INVALID_ELEM_LEN
establish, extent -3                                 ->  8 CFI_INVALID_EXTENT
establish, allocatable with a base address           ->  7 CFI_INVALID_ATTRIBUTE
establish, unallocated allocatable                   ->  0 CFI_SUCCESS
allocate, 2x3                                        ->  0 CFI_SUCCESS
allocate again, base address is not NULL             ->  3 CFI_ERROR_BASE_ADDR_NOT_NULL
deallocate                                           ->  0 CFI_SUCCESS
deallocate again, base address is NULL               ->  2 CFI_ERROR_BASE_ADDR_NULL
allocate, absurd extents                             -> 11 CFI_ERROR_MEM_ALLOCATION
section, upper bound 3 on an extent-3 dimension      -> 12 CFI_ERROR_OUT_OF_BOUNDS
section, in bounds                                   ->  0 CFI_SUCCESS
setpointer, result is not a pointer                  ->  7 CFI_INVALID_ATTRIBUTE

gcc -std=c11 -Wall -Wextra -pedantic -c 01_describe.c -o describe.o
gfortran -std=f2023 -Wall -Wextra -pedantic -fimplicit-none -fcheck=all 01_describe.f90 describe.o -o describe

gcc -std=c11 -Wall -Wextra -pedantic -fPIC -I/usr/lib/llvm-23/include/flang -c 01_describe.c -o describe.o
flang-23 01_describe.f90 describe.o -o describe