Merge branch 'issue-422-implement-by-refs' of github.com:sourceryinstitute/OpenCoarrays into issue-422-implement-by-refs

Author: zbeekman

prerequisites/acceptable_compiler.f90

@@ -35,5 +35,5 @@
 program main
   use iso_fortran_env, only : compiler_version
   implicit none
-  print *,(compiler_version() >= "GCC version 6.1.0 ") .and. (compiler_version() < "GCC version 7.0.0 ")
+  print *,(compiler_version() >= "GCC version 6.1.0 ")
 end program

prerequisites/install-functions/find_or_install.sh

@@ -173,7 +173,7 @@ find_or_install()
 
         else
 
-          info "$this_script: Checking whether $executable in PATH wraps gfortran version >= $(./build.sh -V gcc) and < 7.0.0 ... "
+          info "$this_script: Checking whether $executable in PATH wraps gfortran version >= $(./build.sh -V gcc)... "
           $executable acceptable_compiler.f90 -o acceptable_compiler || true;
           $executable print_true.f90 -o print_true || true;
           if [[ -f ./acceptable_compiler && -f ./print_true ]]; then

src/tests/unit/send-get/get_array_test.f90

@@ -7,6 +7,8 @@ program main
   integer, parameter :: n = 3
   integer, parameter :: m = 4
 
+  logical :: error_printed=.false.
+
   ! Allocatable coarrays
   call one(-5, 1)
   call one(0, 0)
@@ -16,7 +18,11 @@ program main
   ! Static coarrays
   call two()
   call three()
-  write(*,*) 'Test passed'
+
+  if (error_printed)  error stop
+  sync all
+
+  if (this_image()==1) print *,'Test passed.'
 contains
   subroutine one(lb1, lb2)
     integer, value :: lb1, lb2
@@ -42,7 +48,7 @@ subroutine one(lb1, lb2)
     end if
     sync all
     if(this_image()==1) then
-       if(any (a /= c)) error stop "ARRAY = SCALAR failed in get_array_test"
+       if(any (a /= c)) call print_and_register( "ARRAY = SCALAR failed in get_array_test")
     endif
 
     ! Whole array: ARRAY = ARRAY
@@ -59,7 +65,7 @@ subroutine one(lb1, lb2)
           print *, a
           print *, c
           ! FIXME: Without the print lines above, it always fails. Why?
-          error stop "ARRAY = ARRAY failed in get_array_test"
+          call print_and_register( "ARRAY = ARRAY failed in get_array_test")
        end if
     endif
 
@@ -98,7 +104,7 @@ subroutine one(lb1, lb2)
           print *, this_image(), ': ', a
           print *, this_image(), ': ', c
           ! FIXME: Without the print lines above, it always fails. Why?
-          error stop "scalar assignment failed in get_array_test"
+          call print_and_register( "scalar assignment failed in get_array_test")
        end if
     endif
     ! Array sections with different ranges and pos/neg strides
@@ -130,7 +136,7 @@ subroutine one(lb1, lb2)
                                   print *, a
                                   print *, c
                                   print *, a-c
-                                  error stop "array sections with ranges and strides failed in get_array_test"
+                                  call print_and_register( "array sections with ranges and strides failed in get_array_test")
                                endif
                             end if
                             ! ARRAY = ARRAY
@@ -155,7 +161,7 @@ subroutine one(lb1, lb2)
                                   print *, a
                                   print *, c
                                   print *, a-c
-                                  error stop "array sections with ranges and strides failed in get_array_test"
+                                  call print_and_register( "array sections with ranges and strides failed in get_array_test")
                                endif
                             end if
                          end do
@@ -189,7 +195,7 @@ subroutine two()
     sync all
     if (this_image() == num_images()) then
       if (any (a /= caf)) &
-           error stop "Array = scalar failed in subroutine two get_array_test"
+           call print_and_register( "Array = scalar failed in subroutine two get_array_test")
     end if
 
     ! Whole array: ARRAY = ARRAY
@@ -203,7 +209,7 @@ subroutine two()
     sync all
     if (this_image() == num_images()) then
       if (any (a /= caf)) &
-           error stop "Array = array failed in subroutine two get_array_test"
+           call print_and_register( "Array = array failed in subroutine two get_array_test")
     end if
 
     ! Scalar assignment
@@ -235,7 +241,7 @@ subroutine two()
     sync all
     if (this_image() == num_images()) then
       if (any (a /= caf)) &
-           error stop "scalar assignment failed in subroutine two get_array_test"
+           call print_and_register( "scalar assignment failed in subroutine two get_array_test")
     end if
 
     ! Array sections with different ranges and pos/neg strides
@@ -280,7 +286,7 @@ subroutine two()
                         print *, a
                         print *, caf
                         print *, a-caf
-                        error stop "arrays with ranges and strides failed sub. two get_array_test failed"
+                        call print_and_register( "arrays with ranges and strides failed sub. two get_array_test failed")
                       endif
                     end if
                   end do
@@ -314,7 +320,7 @@ subroutine three()
     sync all
     if (this_image() == num_images()) then
       if (any (a /= caf)) &
-           error stop "Array = scalar subroutine three get_array_test failed"
+           call print_and_register( "Array = scalar subroutine three get_array_test failed")
     end if
 
     ! Whole array: ARRAY = ARRAY
@@ -328,7 +334,7 @@ subroutine three()
     sync all
     if (this_image() == num_images()) then
       if (any (a /= caf)) &
-           error stop "Array = array subroutine three get_array_test failed"
+           call print_and_register( "Array = array subroutine three get_array_test failed")
     end if
 
     ! Scalar assignment
@@ -360,7 +366,7 @@ subroutine three()
     sync all
     if (this_image() == num_images()) then
       if (any (a /= caf)) &
-           error stop "scalar assignment subroutine three get_array_test failed"
+           call print_and_register( "scalar assignment subroutine three get_array_test failed")
     end if
 
     ! Array sections with different ranges and pos/neg strides
@@ -405,7 +411,7 @@ subroutine three()
                         print *, a
                         print *, caf
                         print *, a-caf
-                        error stop "range stride in subroutine three get_array_test failed"
+                        call print_and_register( "range stride in subroutine three get_array_test failed")
                       endif
                     end if
                   end do
@@ -417,4 +423,12 @@ subroutine three()
       end do
     end do
   end subroutine three
+
+  subroutine print_and_register(error_message)
+    use iso_fortran_env, only : error_unit
+    character(len=*), intent(in) :: error_message
+    write(error_unit,*) error_message
+    error_printed=.true.
+  end subroutine
+
 end program main

src/tests/unit/send-get/get_convert_char_array.f90

@@ -4,7 +4,7 @@
 !!
 !! FOO = BAR [N]
 !!
-!! where 
+!! where
 !!
 !!  FOO                BAR                 images
 !! character(len=20) character(len=10)   N == me
@@ -41,6 +41,7 @@ program get_convert_char_array
   character(kind=1, len=5)                 :: str_k1_arr(1:4)
   character(kind=4, len=5), codimension[*] :: co_str_k4_arr(1:4)
   character(kind=4, len=5)                 :: str_k4_arr(1:4)
+  logical :: error_printed=.false.
 
   associate(me => this_image(), np => num_images())
     if (np < 2) error stop 'Can not run with less than 2 images.'
@@ -55,80 +56,103 @@ program get_convert_char_array
     if (me == 1) then
       str_k1_scal = co_str_k1_scal[1]
       print *, '#' // str_k1_scal // '#, len:', len(str_k1_scal)
-      if (co_str_k1_scal /= str_k1_scal // '          ') error stop 'get scalar kind=1 to kind=1 self failed.'
+      if (co_str_k1_scal /= str_k1_scal // '          ') call print_and_register( 'get scalar kind=1 to kind=1 self failed.')
 
       str_k4_scal = co_str_k4_scal[1]
       print *, 4_'#' // str_k4_scal // 4_'#, len:', len(str_k4_scal)
-      if (co_str_k4_scal /= str_k4_scal // 4_'          ') error stop 'get scalar kind=4 to kind=4 self failed.'
+      if (co_str_k4_scal /= str_k4_scal // 4_'          ') call print_and_register( 'get scalar kind=4 to kind=4 self failed.')
 
       str_k4_scal = co_str_k1_scal[1]
       print *, 4_'#' // str_k4_scal // 4_'#, len:', len(str_k4_scal)
-      if (co_str_k4_scal /= str_k4_scal // 4_'          ') error stop 'get scalar kind=1 to kind=4 self failed.'
+      if (co_str_k4_scal /= str_k4_scal // 4_'          ') call print_and_register( 'get scalar kind=1 to kind=4 self failed.')
 
       str_k1_scal = co_str_k4_scal[1]
       print *, '#' // str_k1_scal // '#, len:', len(str_k1_scal)
-      if (co_str_k1_scal /= str_k1_scal // '          ') error stop 'get scalar kind=4 to kind=1 self failed.'
+      if (co_str_k1_scal /= str_k1_scal // '          ') call print_and_register( 'get scalar kind=4 to kind=1 self failed.')
     end if
 
     ! Do the same for arrays but on image 2
     if (me == 2) then
       str_k1_arr(:) = co_str_k1_arr(:)[2]
       print *, '#' // str_k1_arr(:) // '#, len:', len(str_k1_arr(1))
-      if (any(str_k1_arr /= ['abc  ', 'EFG  ', 'klm  ', 'NOP  '])) error stop 'get array kind=1 to kind=1 self failed.'
-     
-      print *, str_k4_arr 
+      if (any(str_k1_arr /= ['abc  ', 'EFG  ', 'klm  ', 'NOP  '])) &
+        call print_and_register( 'get array kind=1 to kind=1 self failed.')
+
+      print *, str_k4_arr
       str_k4_arr(:) = co_str_k4_arr(:)[2]
       print *, 4_'#' // str_k4_arr(:) // 4_'#, len:', len(str_k4_arr(1))
-      if (any(str_k4_arr /= [4_'abc  ', 4_'EFG  ', 4_'klm  ', 4_'NOP  '])) error stop 'get array kind=4 to kind=4 self failed.'
+      if (any(str_k4_arr /= [4_'abc  ', 4_'EFG  ', 4_'klm  ', 4_'NOP  '])) &
+        call print_and_register( 'get array kind=4 to kind=4 self failed.')
 
       str_k4_arr(:) = co_str_k1_arr(:)[2]
       print *, 4_'#' // str_k4_arr(:) // 4_'#, len:', len(str_k4_arr(1))
-      if (any(str_k4_arr /= [ 4_'abc  ', 4_'EFG  ', 4_'klm  ', 4_'NOP  '])) error stop 'get array kind=1 to kind=4 self failed.'
+      if (any(str_k4_arr /= [ 4_'abc  ', 4_'EFG  ', 4_'klm  ', 4_'NOP  '])) &
+        call print_and_register( 'get array kind=1 to kind=4 self failed.')
 
       str_k1_arr(:) = co_str_k4_arr(:)[2]
       print *, '#' // str_k1_arr(:) // '#, len:', len(str_k1_arr(1))
-      if (any(str_k1_arr /= ['abc  ', 'EFG  ', 'klm  ', 'NOP  '])) error stop 'get array kind=4 to kind=1 self failed.'
+      if (any(str_k1_arr /= ['abc  ', 'EFG  ', 'klm  ', 'NOP  '])) &
+        call print_and_register( 'get array kind=4 to kind=1 self failed.')
     end if
 
     sync all
     if (me == 1) then
       str_k1_scal = co_str_k1_scal[2]
       print *, '#' // str_k1_scal // '#, len:', len(str_k1_scal)
-      if (co_str_k1_scal /= str_k1_scal // '          ') error stop 'get kind=1 to kind=1 image 2 failed.'
+      if (co_str_k1_scal /= str_k1_scal // '          ') call print_and_register( 'get kind=1 to kind=1 image 2 failed.')
 
       str_k4_scal = co_str_k4_scal[2]
       print *, 4_'#' // str_k4_scal // 4_'#, len:', len(str_k4_scal)
-      if (co_str_k4_scal /= str_k4_scal // 4_'          ') error stop 'get kind=4 to kind=4 image 2 failed.'
+      if (co_str_k4_scal /= str_k4_scal // 4_'          ') call print_and_register( 'get kind=4 to kind=4 image 2 failed.')
     else if (me == 2) then
       str_k4_scal = co_str_k1_scal[1]
       print *, 4_'#' // str_k4_scal // 4_'#, len:', len(str_k4_scal)
-      if (co_str_k4_scal /= str_k4_scal // 4_'          ') error stop 'get kind=1 to kind=4 from image 1 failed.'
+      if (co_str_k4_scal /= str_k4_scal // 4_'          ') call print_and_register( 'get kind=1 to kind=4 from image 1 failed.')
 
       str_k1_scal = co_str_k4_scal[1]
       print *, '#' // str_k1_scal // '#, len:', len(str_k1_scal)
-      if (co_str_k1_scal /= str_k1_scal // '          ') error stop 'get kind=4 to kind=1 from image 1 failed.'
+      if (co_str_k1_scal /= str_k1_scal // '          ') call print_and_register( 'get kind=4 to kind=1 from image 1 failed.')
     end if
 
     str_k1_arr(:) = '#####'
     str_k4_arr(:) = 4_'#####'
-    
+
     sync all
 
     if (me == 1) then
       str_k1_arr(1:2) = co_str_k1_arr(::2)[2]
       print *, str_k1_arr
       if (any(str_k1_arr /= ['abc  ', 'klm  ', '#####', '#####'])) &
-        & error stop "strided get char arr kind 1 to kind 1 failed."
+        & call print_and_register( "strided get char arr kind 1 to kind 1 failed.")
 
       str_k4_arr(1:2) = co_str_k4_arr(::2)[2]
       print *, str_k4_arr
       if (any(str_k4_arr /= [4_'abc  ', 4_'klm  ', 4_'#####', 4_'#####'] )) &
-        & error stop "strided get char arr kind 4 to kind 4 failed."
+        & call print_and_register( "strided get char arr kind 4 to kind 4 failed.")
     end if
 
-    sync all
-    if (me == 1) print *, 'Test passed.'
+    select case(me)
+     case(1)
+       if (error_printed) error stop
+       sync images(2)
+       print *, 'Test passed.'
+     case(2)
+       if (error_printed) error stop
+       sync images(1)
+    end select
+
   end associate
+
+contains
+
+  subroutine print_and_register(error_message)
+    use iso_fortran_env, only : error_unit
+    character(len=*), intent(in) :: error_message
+    write(error_unit,*) error_message
+    error_printed=.true.
+  end subroutine
+
 end program get_convert_char_array
 
 ! vim:ts=2:sts=2:sw=2:
+