native test: Add coarray allocation, test type compliance

.github/workflows/build.yml

@@ -122,7 +122,7 @@ jobs:
             version: latest
             container: ghcr.io/lfortran/lfortran:latest
             native_multi_image: true
-            FFLAGS: --coarray=true -DHAVE_SYNC=0 -DHAVE_COLLECTIVES=0 -DHAVE_TEAM=0
+            FFLAGS: --coarray=true -DHAVE_SYNC=0 -DHAVE_COLLECTIVES=0 -DHAVE_TEAM=0 -DHAVE_EVENT_TYPE=0 -DHAVE_LOCK_TYPE=0 -DHAVE_NOTIFY_TYPE=0
 
           - os: ubuntu-22.04
             compiler: lfortran
@@ -317,7 +317,11 @@ jobs:
           echo "CXX=clang++" >> "$GITHUB_ENV"
         fi
         if [ "${NATIVE_MULTI_IMAGE}" == true ] ; then
-          echo "FFLAGS=$FFLAGS -fcoarray" >> "$GITHUB_ENV"
+          if [[ $COMPILER_VERSION == latest ]] ; then
+            echo "FFLAGS=$FFLAGS -fcoarray -DHAVE_COARRAY -DIGNORE_FAILURES=11" >> "$GITHUB_ENV"
+          else
+            echo "FFLAGS=$FFLAGS -fcoarray -DIGNORE_FAILURES=8" >> "$GITHUB_ENV"
+          fi
         fi
 
     - name: Setup lfortran dependencies and variables

app/native-multi-image.F90

@@ -20,6 +20,7 @@ program native_multi_image
 #ifndef HAVE_SYNC_IMAGES
 #define HAVE_SYNC_IMAGES HAVE_SYNC
 #endif
+
 #ifndef HAVE_COLLECTIVES
 #define HAVE_COLLECTIVES 1
 #endif
@@ -35,16 +36,76 @@ program native_multi_image
 #ifndef HAVE_CO_BROADCAST
 #define HAVE_CO_BROADCAST HAVE_COLLECTIVES
 #endif
+
 #ifndef HAVE_TEAM
 #define HAVE_TEAM 1
 #endif
+#ifndef HAVE_TEAM_TYPE
+#define HAVE_TEAM_TYPE HAVE_TEAM
+#endif
+#ifndef HAVE_EVENT_TYPE
+#define HAVE_EVENT_TYPE 1
+#endif
+#ifndef HAVE_LOCK_TYPE
+#define HAVE_LOCK_TYPE 1
+#endif
+#ifndef HAVE_NOTIFY_TYPE
+#define HAVE_NOTIFY_TYPE 1
+#endif
+! TYPES_IMPORT_PRIF: compiler imports the real PRIF definition of ISO_FORTRAN_ENV types
+#ifndef TYPES_IMPORT_PRIF
+#define TYPES_IMPORT_PRIF 0
+#endif
+
+#ifndef HAVE_COARRAY
+#define HAVE_COARRAY 0
+#endif
+#ifndef HAVE_MAIN_COARRAY
+#define HAVE_MAIN_COARRAY HAVE_COARRAY
+#endif
+#ifndef HAVE_ALLOC_COARRAY
+#define HAVE_ALLOC_COARRAY HAVE_COARRAY
+#endif
 
+! Helper macros
+#define CHECK_TYPE_COMPLIANCE(subject_type, subject, is_team, min_size) \
+  BLOCK ; \
+    integer(c_int8_t), allocatable, target :: bytes(:) ; \
+    bytes = transfer(subject, bytes) ; \
+    call check_type(#subject_type, is_team, min_size, \
+                    storage_size(subject)/8, bytes); \
+  END BLOCK
+
+! Main program
   USE, INTRINSIC :: ISO_FORTRAN_ENV
-  integer :: me, ni, peer, tmp
+  USE, INTRINSIC :: ISO_C_BINDING, only: c_int8_t
+
+  type :: dummy_team_descriptor
+  end type
+  type :: dummy_team_type
+    type(dummy_team_descriptor), pointer :: info => null()
+  end type
+
+  integer :: me, ni, peer, tmp, fail_count = 0
   character(len=5) :: c
 # if HAVE_TEAM
   integer :: team_id
   type(TEAM_TYPE) :: subteam, res
+  type(TEAM_TYPE) :: default_team
+# endif
+# if HAVE_MAIN_COARRAY
+  integer :: sca_int_1[*]
+  integer :: sca_int_2[2,*]
+  integer :: sca_int_3[2,3,*]
+# endif
+# if HAVE_EVENT_TYPE
+      type(event_type), target :: default_event[*]
+# endif
+# if HAVE_NOTIFY_TYPE
+      type(notify_type), target :: default_notify[*]
+# endif
+# if HAVE_LOCK_TYPE
+      type(lock_type), target :: default_lock[*]
 # endif
 
   me = THIS_IMAGE()
@@ -109,6 +170,9 @@ program native_multi_image
 # endif
 
 # if HAVE_TEAM
+#   if HAVE_TEAM_TYPE
+      CHECK_TYPE_COMPLIANCE(TEAM_TYPE, default_team, .true., 0)
+#   endif
   call status("Testing TEAMS...")
   res = GET_TEAM(CURRENT_TEAM)
   res = GET_TEAM(INITIAL_TEAM)
@@ -126,13 +190,38 @@ program native_multi_image
   write(*,'(A,I3)') "After END TEAM statement, TEAM_NUMBER() is ", TEAM_NUMBER()
 # endif
 
+# if HAVE_EVENT_TYPE
+  CHECK_TYPE_COMPLIANCE(EVENT_TYPE, default_event, .false., 64)
+# endif
+
+# if HAVE_LOCK_TYPE
+  CHECK_TYPE_COMPLIANCE(LOCK_TYPE, default_lock, .false., 64)
+# endif
+
+# if HAVE_NOTIFY_TYPE
+  CHECK_TYPE_COMPLIANCE(NOTIFY_TYPE, default_notify, .false., 64)
+# endif
+
+  call sync_all
+  call test_allocatable_coarray
+  call test_allocatable_coarray
+
   call sync_all
   write(*,'(A,I1,A,I1,A)') "Goodbye from image ", me, " of ", ni, " images"
 
   ! explicit flush for now until we have multi-image stop support
   call flush_all
   call sync_all
-  stop
+  if (fail_count > 0) then
+    call status("ERROR: "//tostring(fail_count)//" tests FAILED.")
+  else
+    call status("All tests passed.")
+  end if
+#if IGNORE_FAILURES
+  call status("WARNING: Ignoring "//tostring(IGNORE_FAILURES)//" failures.")
+  fail_count = MAX(0, fail_count - IGNORE_FAILURES)
+#endif
+  stop fail_count
 
   contains
     subroutine sync_all
@@ -148,11 +237,119 @@ subroutine status(str)
       character(len=*) :: str
       call flush_all
       call sync_all
-      if (THIS_IMAGE() == 1) write(*,*) str
+      if (THIS_IMAGE() == 1) write(*,'(A)') str
       call flush_all
       call sync_all
     end subroutine
 
+    subroutine test_allocatable_coarray()
+#   if HAVE_ALLOC_COARRAY
+#   define CHECK_ALLOC(coarray, expect) \
+      if (ALLOCATED(coarray) .neqv. expect) then ; \
+        if (THIS_IMAGE() == 1) write(*,'(A)') __FILE__//":"//tostring(__LINE__)//": ERROR: " // \
+           " ALLOCATED(" // #coarray // ") = " // MERGE("true ","false",ALLOCATED(coarray)) ; \
+        fail_count = fail_count + 1 ; \
+      end if
+
+      logical, save :: once = .true.
+      integer, allocatable :: aca_int_1[:]
+      integer, allocatable :: aca_int_2[:,:]
+      integer, save, allocatable :: aca_int_3[:,:,:]
+      CHECK_ALLOC(aca_int_1, .false.)
+      CHECK_ALLOC(aca_int_2, .false.)
+      CHECK_ALLOC(aca_int_3, .false.)
+      if (once) then
+        once = .false.
+        call status("Testing ALLOCATABLE coarrays...")
+        ALLOCATE(aca_int_1[*])
+        ALLOCATE(aca_int_2[2,*])
+        ALLOCATE(aca_int_3[2,3,*])
+        CHECK_ALLOC(aca_int_1, .true.)
+        CHECK_ALLOC(aca_int_2, .true.)
+        CHECK_ALLOC(aca_int_3, .true.)
+      end if
+#   endif
+    end subroutine
+
+    function tostring(int) result(res)
+      integer :: int
+      character(len=128) :: str
+      character(len=:), allocatable :: res
+      write(str, *) int
+      res = trim(adjustl(str))
+    end function
+
+    function hexdump(arr) result(res)
+      integer(c_int8_t), intent(in) :: arr(:)
+      character(len=:), allocatable :: res
+      character(len=4096) :: buf
+      write(buf, '(*(Z2, 1X))') arr
+      res = trim(buf)
+    end function
+
+    subroutine check_type(type_name, is_team, min_size, subject_size, default_bytes)
+      character(len=*), intent(in) :: type_name
+      logical, intent(in) :: is_team
+      integer, intent(in) :: min_size, subject_size
+      integer(c_int8_t), target, intent(in) :: default_bytes(:)
+      character(len=:), allocatable :: diag
+#   if HAVE_TEAM
+      type(TEAM_TYPE) :: team_var
+      type(dummy_team_type) :: dummy_team_type_var
+      integer, parameter :: reference_size = storage_size(dummy_team_type_var)/8
+#   endif
+
+      call status("Testing " // type_name // "...")
+
+      if (subject_size /= size(default_bytes)) ERROR STOP "INTERNAL ERROR: representation size mismatch"
+
+      if (is_team) then
+#     if HAVE_TEAM
+        ! check size, should be an exact match
+        if (subject_size == reference_size) then
+          diag = "pass"
+        else
+          diag = "FAIL (should be exactly " // tostring(reference_size) // " bytes)"
+          fail_count = fail_count + 1
+        end if
+        call status("  Size of " // type_name // ": " // tostring(subject_size) // " bytes ==> " // diag)
+
+        ! check default initialization
+        dummy_team_type_var = transfer(team_var, dummy_team_type_var)
+        if (.not. associated(dummy_team_type_var%info)) then
+          diag = "pass"
+        else
+          diag = "FAIL (not default-initialized to null(): " // hexdump(default_bytes)// ")"
+          fail_count = fail_count + 1
+        end if
+        call status("  Default init of " // type_name // " ==> " // diag)
+#     endif
+      else
+#     if TYPES_IMPORT_PRIF
+        diag = "(validation skipped)"
+#     else
+        ! check size, should not be less than min_size
+        if (subject_size >= min_size) then
+          diag = "pass"
+        else
+          diag = "FAIL (should be >= " // tostring(min_size) // " bytes)"
+          fail_count = fail_count + 1
+        end if
+#     endif
+        call status("  Size of " // type_name // ": " // tostring(subject_size) // " bytes ==> " // diag)
+
+        ! check default initialization
+        if (all(default_bytes == 0)) then
+          diag = "pass"
+        else
+          diag = "FAIL (non-zero value at byte " // tostring((findloc(default_bytes /= 0, .true., dim=1))) // ": " // &
+                 hexdump(default_bytes) // ")"
+          fail_count = fail_count + 1
+        end if
+        call status("  Default init of " // type_name // " ==> " // diag)
+      end if
+    end subroutine
+
 #else
   stop "Native multi-image test disabled"
 #endif