re PR fortran/18918 (Eventually support Fortran 2008's coarrays [co-arrays])

2011-05-03  Tobias Burnus  <burnus@net-b.de>

        PR fortran/18918
        * gfortran.dg/coarray/caf.dg: New.
        * gfortran.dg/coarray/image_index_1.f90: New, copied
        from ../coarray_16.f90.

From-SVN: r173341

3 files changed, 182 insertions, 0 deletions

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 332b209..5ce6d37 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2011-05-03  Tobias Burnus  <burnus@net-b.de>
+
+	PR fortran/18918
+	* gfortran.dg/coarray/caf.dg: New.
+	* gfortran.dg/coarray/image_index_1.f90: New, copied
+	from ../coarray_16.f90.
+
 2011-05-03  Paolo Carlini  <paolo.carlini@oracle.com>
 
 	PR c++/28501
diff --git a/gcc/testsuite/gfortran.dg/coarray/caf.exp b/gcc/testsuite/gfortran.dg/coarray/caf.exp
new file mode 100644
index 0000000..c7e46f6
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/caf.exp
@@ -0,0 +1,76 @@
+# Copyright (C) 2011 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with GCC; see the file COPYING3.  If not see
+# <http://www.gnu.org/licenses/>.
+#
+# Contributed by Tobias Burnus <burnus@net-b.de>
+
+
+# Test coarray support.
+#
+# For the compilation tests, all files are compiles with the
+# option -fcoarray=single and with -fcoarray=lib
+#
+# For the link and execution tests, for -fcoarray=lib the
+# libcaf_single library is linked. Additionally, with the
+# required settings another CAF library is used.
+
+# Load procedures from common libraries. 
+load_lib gfortran-dg.exp
+
+# If a testcase doesn't have special options, use these.
+global DEFAULT_FFLAGS
+if ![info exists DEFAULT_FFLAGS] then {
+    set DEFAULT_FFLAGS " -pedantic-errors"
+}
+
+dg-init
+
+global runtests
+global DG_TORTURE_OPTIONS torture_with_loops
+
+torture-init
+set-torture-options $DG_TORTURE_OPTIONS
+
+# Main loop.
+foreach test [lsort [glob -nocomplain $srcdir/$subdir/*.\[fF\]{,90,95,03,08} ]] {
+    # If we're only testing specific files and this isn't one of them, skip it.
+    if ![runtest_file_p $runtests $test] then {
+	continue
+    }
+
+# Enable if you want to test several options:
+#    # look if this is dg-do-run test, in which case
+#    # we cycle through the option list, otherwise we don't
+#    if [expr [search_for $test "dg-do run"]] {
+#	set option_list $torture_with_loops
+#    } else {
+#	set option_list [list { -O } ]
+#    }
+    set option_list [list { -O2 } ]
+
+    set nshort [file tail [file dirname $test]]/[file tail $test]
+
+    foreach flags $option_list {
+	verbose "Testing $nshort (single), $flags" 1
+	dg-test $test "-fcoarray=single $flags" "" 
+    }
+
+    foreach flags $option_list {
+	verbose "Testing $nshort (libcaf_single), $flags" 1
+	dg-test $test "-fcoarray=lib $flags -lcaf_single" ""
+    }
+}
+torture-finish
+dg-finish
diff --git a/gcc/testsuite/gfortran.dg/coarray/image_index_1.f90 b/gcc/testsuite/gfortran.dg/coarray/image_index_1.f90
new file mode 100644
index 0000000..00e5e09
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/coarray/image_index_1.f90
@@ -0,0 +1,99 @@
+! { dg-do run }
+!
+! Run-time test for IMAGE_INDEX with cobounds only known at
+! the compile time, suitable for any number of NUM_IMAGES()
+! For compile-time cobounds, the -fcoarray=lib version still
+! needs to run-time evalulation if image_index returns > 1
+! as image_index is 0 if the index would exceed num_images().
+!
+! Please set num_images() to >= 13, if possible.
+!
+! PR fortran/18918
+!
+
+program test_image_index
+implicit none
+integer :: index1, index2, index3
+logical :: one
+
+integer, allocatable :: a(:)[:,:,:], b(:)[:,:], c(:,:)[:]
+integer, save :: d(2)[-1:3, *]
+integer, save :: e(2)[-1:-1, 3:*]
+
+one = num_images() == 1
+
+allocate(a(1)[3:3, -4:-3, 88:*])
+allocate(b(2)[-1:0,0:*])
+allocate(c(3,3)[*])
+
+index1 = image_index(a, [3, -4, 88] )
+index2 = image_index(b, [-1, 0] )
+index3 = image_index(c, [1] )
+if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort()
+
+
+index1 = image_index(a, [3, -3, 88] )
+index2 = image_index(b, [0, 0] )
+index3 = image_index(c, [2] )
+
+if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) &
+  call abort()
+if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) &
+  call abort()
+
+
+index1 = image_index(d, [-1, 1] )
+index2 = image_index(d, [0, 1] )
+
+if (one .and. (index1 /= 1 .or. index2 /= 0)) &
+  call abort()
+if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) &
+  call abort()
+
+index1 = image_index(e, [-1, 3] )
+index2 = image_index(e, [-1, 4] )
+
+if (one .and. (index1 /= 1 .or. index2 /= 0)) &
+  call abort()
+if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) &
+  call abort()
+
+call test(1, a,b,c)
+
+! The following test is in honour of the F2008 standard:
+deallocate(a)
+allocate(a (10) [10, 0:9, 0:*])
+
+index1 = image_index(a, [1, 0, 0] )
+index2 = image_index(a, [3, 1, 2] )  ! = 213, yeah!
+index3 = image_index(a, [3, 1, 0] )  ! = 13
+
+if (num_images() < 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 0)) &
+  call abort()
+if (num_images() >= 213 .and. (index1 /= 1 .or. index2 /= 213 .or. index3 /= 13)) &
+  call abort()
+if (num_images() >= 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 13)) &
+  call abort()
+
+
+contains
+subroutine test(n, a, b, c)
+  integer :: n
+  integer :: a(1)[3*n:3*n, -4*n:-3*n, 88*n:*], b(2)[-1*n:0*n,0*n:*], c(3*n,3*n)[*]
+
+  index1 = image_index(a, [3, -4, 88] )
+  index2 = image_index(b, [-1, 0] )
+  index3 = image_index(c, [1] )
+  if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort()
+
+
+  index1 = image_index(a, [3, -3, 88] )
+  index2 = image_index(b, [0, 0] )
+  index3 = image_index(c, [2] )
+
+  if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) &
+    call abort()
+  if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) &
+    call abort()
+end subroutine test
+end program test_image_index