add lubounds test

Author: scivision

CMakeLists.txt

@@ -43,7 +43,7 @@ endif()
 
 foreach(a IN ITEMS
   iso_fortran_binding
-  allocate contiguous
+  allocate bounds contiguous
   array bool error exception
   iterator
   glibc malloc

src/bounds/bounds.c

@@ -0,0 +1,103 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <ISO_Fortran_binding.h>
+#include <inttypes.h>
+
+#include "bounds.h"
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+/* ==================== 1D Version ==================== */
+bool c_bounder(CFI_cdesc_t *a,
+               CFI_index_t fortran_lower,   // Original Fortran lower bound
+               CFI_index_t fortran_upper)   // Original Fortran upper bound
+{
+    printf("\n=== C side: c_bounder (1D) called ===\n");
+
+    if (a == NULL) {
+        fprintf(stderr, "ERROR: NULL descriptor\n");
+        return false;
+    }
+
+    if (a->rank != 1) {
+        fprintf(stderr, "ERROR: Expected rank 1, got %" PRId64 "\n", (int64_t)a->rank);
+        return false;
+    }
+
+    CFI_dim_t *dim = &a->dim[0];
+    CFI_index_t c_lower = dim->lower_bound;        // This is almost always 0
+    CFI_index_t extent  = dim->extent;
+    CFI_index_t c_upper = c_lower + extent - 1;
+
+    printf("C Descriptor:   lower=%td, upper=%td, extent=%td\n", c_lower, c_upper, extent);
+    printf("Fortran Array:  lower=%td, upper=%td\n", fortran_lower, fortran_upper);
+
+    // === Correct validation for bind(c) ===
+    if (c_lower != 0) {
+        fprintf(stderr, "WARNING: C lower bound is not 0 (got %td)\n", c_lower);
+    }
+
+    if (extent != (fortran_upper - fortran_lower + 1)) {
+        fprintf(stderr, "ERROR: Extent mismatch! Expected %td, got %td\n",
+                (fortran_upper - fortran_lower + 1), extent);
+        return false;
+    }
+
+    printf("✓ Extent check PASSED\n");
+    printf("✓ C descriptor uses 0-based lower bound (standard behavior)\n");
+
+    // Optional data modification
+    if (a->base_addr && extent > 0) {
+        float *data = (float*)a->base_addr;
+        data[0] = 999.0f;
+        if (extent > 1)
+            data[extent-1] = -999.0f;
+    }
+
+    printf("=== c_bounder (1D) finished ===\n\n");
+    return true;
+}
+
+/* ==================== 2D Version ==================== */
+bool c_bounder_2d(CFI_cdesc_t *a,
+                  CFI_index_t fl1, CFI_index_t fu1,
+                  CFI_index_t fl2, CFI_index_t fu2)
+{
+    printf("\n=== C side: c_bounder_2d called ===\n");
+
+    if (a == NULL || a->rank != 2) {
+        fprintf(stderr, "ERROR: Expected rank 2\n");
+        return false;
+    }
+
+    // Dim 1
+    CFI_index_t extent1 = a->dim[0].extent;
+    if (extent1 != (fu1 - fl1 + 1)) {
+        fprintf(stderr, "ERROR: Dim1 extent mismatch\n");
+        return false;
+    }
+
+    // Dim 2
+    CFI_index_t extent2 = a->dim[1].extent;
+    if (extent2 != (fu2 - fl2 + 1)) {
+        fprintf(stderr, "ERROR: Dim2 extent mismatch\n");
+        return false;
+    }
+
+    printf("✓ 2D Extent check PASSED: [%td:%td, %td:%td]\n", fl1, fu1, fl2, fu2);
+    printf("✓ C descriptor lower bounds normalized to 0 (standard)\n");
+
+    if (a->base_addr) {
+        float *data = (float*)a->base_addr;
+        data[0] = 999.0f;
+    }
+
+    printf("=== c_bounder_2d finished ===\n\n");
+    return true;
+}
+
+#ifdef __cplusplus
+}
+#endif

src/bounds/bounds.h

@@ -0,0 +1,6 @@
+#if defined(__STDC_VERSION__) && __STDC_VERSION__ < 202311L
+#include <stdbool.h>
+#endif
+
+bool c_bounder(CFI_cdesc_t*, CFI_index_t, CFI_index_t);
+bool c_bounder_2d(CFI_cdesc_t*, CFI_index_t, CFI_index_t, CFI_index_t, CFI_index_t);

test/bounds/CMakeLists.txt

@@ -0,0 +1,5 @@
+set_property(DIRECTORY PROPERTY LABELS bounds)
+
+add_executable(bounds_fortran bounds.f90 ${PROJECT_SOURCE_DIR}/src/bounds/bounds.c)
+target_include_directories(bounds_fortran INTERFACE ${PROJECT_SOURCE_DIR}/src/bounds)
+add_test(NAME BoundsFortran COMMAND bounds_fortran)

test/bounds/bounds.f90

@@ -0,0 +1,118 @@
+program test_bindc_bounds
+   use, intrinsic :: iso_fortran_env
+   use, intrinsic :: iso_c_binding
+   implicit none
+
+   interface
+      logical(C_BOOL) function c_bounder(a, fl, fu) bind(c, name="c_bounder")
+        import :: c_float, c_int64_t, C_BOOL
+         real(c_float), intent(inout) :: a(:)
+         integer(c_int64_t), value :: fl, fu
+      end function
+
+      logical(C_BOOL) function c_bounder_2d(a, fl1, fu1, fl2, fu2) bind(c, name="c_bounder_2d")
+        import :: c_float, c_int64_t, C_BOOL
+         real(c_float), intent(inout) :: a(:,:)
+         integer(c_int64_t), value :: fl1, fu1, fl2, fu2
+      end function
+   end interface
+
+   call test_default_bounds()
+   call test_nondefault_bounds()
+   call test_multidim()
+   call test_array_section()
+   call test_large_array()
+
+   write(output_unit, '(a)') "All bounds checks passed."
+
+contains
+
+   subroutine check_bounds(a, label, expected_l, expected_u)
+      real, allocatable, intent(in) :: a(:)
+      character(*), intent(in) :: label
+      integer, intent(in) :: expected_l, expected_u
+      integer :: l, u
+
+      l = lbound(a,1)
+      u = ubound(a,1)
+
+      if (l /= expected_l .or. u /= expected_u) then
+         write(error_unit, '(a,": FAIL got [",i0,":",i0,"] expected [",i0,":",i0,"]")') &
+            label, l, u, expected_l, expected_u
+         error stop "Fortran bounds corrupted"
+      end if
+   end subroutine
+
+   subroutine test_default_bounds()
+      real, allocatable :: a(:)
+      allocate(a(1:10))
+      call check_bounds(a, "default before", 1, 10)
+      if (.not. c_bounder(a, 1_c_int64_t, 10_c_int64_t)) then
+         error stop "C bounder failed"
+      end if
+      call check_bounds(a, "default after ", 1, 10)
+   end subroutine
+
+   subroutine test_nondefault_bounds()
+      real, allocatable :: a(:)
+      allocate(a(-3:6))
+      call check_bounds(a, "nondefault before", -3, 6)
+      if (.not. c_bounder(a, -3_c_int64_t, 6_c_int64_t)) then
+         error stop "C bounder failed"
+      end if
+      call check_bounds(a, "nondefault after ", -3, 6)
+   end subroutine
+
+   subroutine test_multidim()
+      real, allocatable :: a(:,:)
+      allocate(a(-2:5, 10:20))
+
+      if (lbound(a,1)/=-2 .or. ubound(a,1)/=5 .or. &
+          lbound(a,2)/=10 .or. ubound(a,2)/=20) then
+         error stop "Multidim setup failed"
+      end if
+
+      if (.not. c_bounder_2d(a, -2_c_int64_t, 5_c_int64_t, 10_c_int64_t, 20_c_int64_t)) then
+         error stop "C bounder 2D failed"
+      end if
+
+      if (lbound(a,1)/=-2 .or. ubound(a,1)/=5 .or. &
+          lbound(a,2)/=10 .or. ubound(a,2)/=20) then
+         error stop "Multidim bounds corrupted"
+      end if
+   end subroutine
+
+   subroutine test_array_section()
+      real, allocatable, target :: a(:)
+      real, pointer :: p(:)
+
+      allocate(a(-10:20))
+      p => a(5:15)   ! pointer lower bound defaults to 1 here
+
+      if (lbound(p,1) /= 1 .or. ubound(p,1) /= 11) then
+         error stop "Section setup failed"
+      end if
+
+      ! Pass the section (C will see 0-based)
+      if (.not. c_bounder(p, 5_c_int64_t, 15_c_int64_t)) then
+         error stop "C bounder failed"
+      end if
+
+      ! Original array should still be intact
+      if (lbound(a,1) /= -10 .or. ubound(a,1) /= 20) then
+         error stop "Original array corrupted via section"
+      end if
+
+      print '(a)', "Array section test passed"
+   end subroutine
+
+   subroutine test_large_array()
+      real, allocatable :: a(:)
+      allocate(a(1:1000000))
+      if (.not. c_bounder(a, 1_c_int64_t, 1000000_c_int64_t)) then
+         error stop "C bounder failed"
+      end if
+      print '(a)', "Large array test passed"
+   end subroutine
+
+end program