aboutsummaryrefslogtreecommitdiff
path: root/gdb/testsuite/gdb.fortran
diff options
context:
space:
mode:
authorNils-Christian Kempke <nils-christian.kempke@intel.com>2022-04-11 14:06:56 +0200
committerNils-Christian Kempke <nils-christian.kempke@intel.com>2022-04-11 14:06:56 +0200
commit891e4190ba705373eec7b374209478215fff5401 (patch)
tree5d73fbd42f1e723066910ce02db03e4a27482c07 /gdb/testsuite/gdb.fortran
parent04ba65365054e37461b4fd904ff9c00d88023b02 (diff)
downloadgdb-891e4190ba705373eec7b374209478215fff5401.zip
gdb-891e4190ba705373eec7b374209478215fff5401.tar.gz
gdb-891e4190ba705373eec7b374209478215fff5401.tar.bz2
gdb/fortran: rewrite intrinsic handling and add some missing overloads
The operators FLOOR, CEILING, CMPLX, LBOUND, UBOUND, and SIZE accept (some only with Fortran 2003) the optional parameter KIND. This parameter determines the kind of the associated return value. So far, implementation of this kind parameter has been missing in GDB. Additionally, the one argument overload for the CMPLX intrinsic function was not yet available. This patch adds overloads for all above mentioned functions to the Fortran intrinsics handling in GDB. It re-writes the intrinsic function handling section to use the helper methods wrap_unop_intrinsic/wrap_binop_intrinsic/wrap_triop_intrinsic. These methods define the action taken when a Fortran intrinsic function is called with a certain amount of arguments (1/2/3). The helper methods fortran_wrap2_kind and fortran_wrap3_kind have been added as equivalents to the existing wrap and wrap2 methods. After adding more overloads to the intrinsics handling, some of the operation names were no longer accurate. E.g. UNOP_FORTRAN_CEILING has been renamed to FORTRAN_CEILING as it is no longer a purely unary intrinsic function. This patch also introduces intrinsic functions with one, two, or three arguments to the Fortran parser and the UNOP_OR_BINOP_OR_TERNOP_INTRINSIC token has been added.
Diffstat (limited to 'gdb/testsuite/gdb.fortran')
-rw-r--r--gdb/testsuite/gdb.fortran/intrinsics.exp46
-rw-r--r--gdb/testsuite/gdb.fortran/lbound-ubound.F9049
-rw-r--r--gdb/testsuite/gdb.fortran/lbound-ubound.exp29
-rw-r--r--gdb/testsuite/gdb.fortran/size.exp84
-rw-r--r--gdb/testsuite/gdb.fortran/size.f90213
5 files changed, 351 insertions, 70 deletions
diff --git a/gdb/testsuite/gdb.fortran/intrinsics.exp b/gdb/testsuite/gdb.fortran/intrinsics.exp
index c402073..29cff35 100644
--- a/gdb/testsuite/gdb.fortran/intrinsics.exp
+++ b/gdb/testsuite/gdb.fortran/intrinsics.exp
@@ -61,15 +61,37 @@ gdb_test "p mod (-8, 5)" " = -3"
gdb_test "p mod (8, -5)" " = 3"
gdb_test "p mod (-8, -5)" " = -3"
-# Test CEILING
+# Test CEILING and FLOOR.
+gdb_test "p floor (3.7)" " = 3"
gdb_test "p ceiling (3.7)" " = 4"
-gdb_test "p ceiling (-3.7)" " = -3"
-# Test FLOOR
-
-gdb_test "p floor (3.7)" " = 3"
gdb_test "p floor (-3.7)" " = -4"
+gdb_test "p ceiling (-3.7)" " = -3"
+
+gdb_test "p ceiling (3)" "argument to CEILING must be of type float"
+gdb_test "p floor (1)" "argument to FLOOR must be of type float"
+
+foreach op {floor ceiling} {
+ gdb_test "ptype ${op} (3.7)" "integer\\*4"
+ gdb_test "ptype ${op} (-1.1, 1)" "type = integer\\*1"
+ gdb_test "ptype ${op} (-1.1, 2)" "type = integer\\*2"
+ gdb_test "ptype ${op} (-1.1, 3)" "unsupported kind 3 for type integer\\*4"
+ gdb_test "ptype ${op} (-1.1, 4)" "type = integer\\*4"
+ gdb_test "ptype ${op} (-1.1, 8)" "type = integer\\*8"
+
+ # The actual overflow behavior differs in ifort/ifx/gfortran - this tests
+ # the GDB internal overflow behavior - not a compiler dependent one.
+ gdb_test "p ${op} (129.0,1)" " = -127"
+ gdb_test "p ${op} (129.0,2)" " = 129"
+ gdb_test "p ${op} (-32770.0,1)" " = -2"
+ gdb_test "p ${op} (-32770.0,2)" " = 32766"
+ gdb_test "p ${op} (-32770.0,4)" " = -32770"
+ gdb_test "p ${op} (2147483652.0,1)" " = 4"
+ gdb_test "p ${op} (2147483652.0,2)" " = 4"
+ gdb_test "p ${op} (2147483652.0,4)" " = -2147483644"
+ gdb_test "p ${op} (2147483652.0,8)" " = 2147483652"
+}
# Test MODULO
@@ -85,6 +107,20 @@ gdb_test "ptype MODULO (3.0,2.0)" "type = real\\*8"
gdb_test "p CMPLX (4.1, 2.0)" " = \\(4.$decimal,2\\)"
+gdb_test "p cmplx (4,4)" "= \\(4,4\\)"
+gdb_test "ptype cmplx (4,4)" "= complex\\*4"
+gdb_test "p cmplx (-14,-4)" "= \\(-14,-4\\)"
+gdb_test "p cmplx (4,4,4)" "\\(4,4\\)"
+gdb_test "p cmplx (4,4,8)" "\\(4,4\\)"
+gdb_test "p cmplx (4,4,16)" "\\(4,4\\)"
+gdb_test "ptype cmplx (4,4,4)" "= complex\\*4"
+gdb_test "ptype cmplx (4,4,8)" "= complex\\*8"
+gdb_test "ptype cmplx (4,4,16)" "= complex\\*16"
+
+gdb_test "p cmplx (4,4,1)" "unsupported kind 1 for type complex\\*4"
+gdb_test "p cmplx (4,4,-1)" "unsupported kind -1 for type complex\\*4"
+gdb_test "p cmplx (4,4,2)" "unsupported kind 2 for type complex\\*4"
+
# Test LOC
gdb_test "p/x LOC(l)" "= $hex"
diff --git a/gdb/testsuite/gdb.fortran/lbound-ubound.F90 b/gdb/testsuite/gdb.fortran/lbound-ubound.F90
index 3714572..aa5be85 100644
--- a/gdb/testsuite/gdb.fortran/lbound-ubound.F90
+++ b/gdb/testsuite/gdb.fortran/lbound-ubound.F90
@@ -17,8 +17,8 @@
call do_test (lbound (ARRAY), ubound (ARRAY))
subroutine do_test (lb, ub)
- integer, dimension (:) :: lb
- integer, dimension (:) :: ub
+ integer*4, dimension (:) :: lb
+ integer*4, dimension (:) :: ub
print *, ""
print *, "Expected GDB Output:"
@@ -51,8 +51,8 @@ end subroutine do_test
program test
interface
subroutine do_test (lb, ub)
- integer, dimension (:) :: lb
- integer, dimension (:) :: ub
+ integer*4, dimension (:) :: lb
+ integer*4, dimension (:) :: ub
end subroutine do_test
end interface
@@ -70,11 +70,34 @@ program test
integer, dimension (:), pointer :: pointer1d => null()
+ integer, parameter :: b1 = 127 - 10
+ integer, parameter :: b1_o = 127 + 2
+ integer, parameter :: b2 = 32767 - 10
+ integer, parameter :: b2_o = 32767 + 3
+ integer*8, parameter :: b4 = 2147483647 - 10
+ integer*8, parameter :: b4_o = 2147483647 + 5
+
+ integer, allocatable :: array_1d_1bytes_overflow (:)
+ integer, allocatable :: array_1d_2bytes_overflow (:)
+ integer, allocatable :: array_1d_4bytes_overflow (:)
+ integer, allocatable :: array_2d_1byte_overflow (:,:)
+ integer, allocatable :: array_2d_2bytes_overflow (:,:)
+ integer, allocatable :: array_3d_1byte_overflow (:,:,:)
+
! Allocate or associate any variables as needed.
allocate (other (-5:4, -2:7))
pointer2d => tarray
pointer1d => array (3, 2:5)
+ allocate (array_1d_1bytes_overflow (-b1_o:-b1))
+ allocate (array_1d_2bytes_overflow (b2:b2_o))
+ allocate (array_1d_4bytes_overflow (-b4_o:-b4))
+
+ allocate (array_2d_1byte_overflow (-b1_o:-b1,b1:b1_o))
+ allocate (array_2d_2bytes_overflow (b2:b2_o,-b2_o:b2))
+
+ allocate (array_3d_1byte_overflow (-b1_o:-b1,b1:b1_o,-b1_o:-b1))
+
DO_TEST (neg_array)
DO_TEST (neg_array (-7:-3,-5:-4))
DO_TEST (array)
@@ -90,9 +113,27 @@ program test
DO_TEST (pointer2d)
DO_TEST (tarray)
+ DO_TEST (array_1d_1bytes_overflow)
+ DO_TEST (array_1d_2bytes_overflow)
+
+ DO_TEST (array_1d_4bytes_overflow)
+ DO_TEST (array_2d_1byte_overflow)
+ DO_TEST (array_2d_2bytes_overflow)
+ DO_TEST (array_3d_1byte_overflow)
+
! All done. Deallocate.
+ print *, "" ! Breakpoint before deallocate.
deallocate (other)
+ deallocate (array_3d_1byte_overflow)
+
+ deallocate (array_2d_2bytes_overflow)
+ deallocate (array_2d_1byte_overflow)
+
+ deallocate (array_1d_4bytes_overflow)
+ deallocate (array_1d_2bytes_overflow)
+ deallocate (array_1d_1bytes_overflow)
+
! GDB catches this final breakpoint to indicate the end of the test.
print *, "" ! Final Breakpoint.
diff --git a/gdb/testsuite/gdb.fortran/lbound-ubound.exp b/gdb/testsuite/gdb.fortran/lbound-ubound.exp
index 709b74a..3347136 100644
--- a/gdb/testsuite/gdb.fortran/lbound-ubound.exp
+++ b/gdb/testsuite/gdb.fortran/lbound-ubound.exp
@@ -41,9 +41,10 @@ if [target_info exists gdb,noinferiorio] {
gdb_test_no_output "nosharedlibrary"
gdb_breakpoint [gdb_get_line_number "Test Breakpoint"]
+gdb_breakpoint [gdb_get_line_number "Breakpoint before deallocate\."]
gdb_breakpoint [gdb_get_line_number "Final Breakpoint"]
-set found_final_breakpoint false
+set found_dealloc_breakpoint false
# We place a limit on the number of tests that can be run, just in
# case something goes wrong, and GDB gets stuck in an loop here.
@@ -77,14 +78,14 @@ while { $test_count < 500 } {
set func_name "show_elem"
exp_continue
}
- -re "! Final Breakpoint" {
- set found_final_breakpoint true
+ -re "! Breakpoint before deallocate" {
+ set found_dealloc_breakpoint true
exp_continue
}
-re "$gdb_prompt $" {
set found_prompt true
- if {$found_final_breakpoint
+ if {$found_dealloc_breakpoint
|| ($expected_lbound != "" && $expected_ubound != "")} {
# We're done.
} else {
@@ -93,7 +94,7 @@ while { $test_count < 500 } {
}
}
- if ($found_final_breakpoint) {
+ if ($found_dealloc_breakpoint) {
break
}
@@ -210,10 +211,26 @@ while { $test_count < 500 } {
}
}
+gdb_assert {$found_dealloc_breakpoint} "ran all compiled in tests"
+
+# Test the kind parameter of ubound and lbound a few times.
+gdb_test "p lbound(array_1d_1bytes_overflow, 1, 1)" "= 127"
+gdb_test "p lbound(array_1d_1bytes_overflow, 1, 2)" "= -129"
+gdb_test "p ubound(array_1d_1bytes_overflow, 1, 1)" "= -117"
+
+gdb_test "p lbound(array_1d_2bytes_overflow, 1, 2)" "= 32757"
+gdb_test "p ubound(array_1d_2bytes_overflow, 1, 2)" "= -32766"
+gdb_test "p ubound(array_1d_2bytes_overflow, 1, 4)" "= 32770"
+
+gdb_test "p lbound(array_1d_4bytes_overflow, 1, 4)" "= 2147483644"
+gdb_test "p lbound(array_1d_4bytes_overflow, 1, 8)" "= -2147483652"
+gdb_test "p ubound(array_1d_4bytes_overflow, 1, 4)" "= -2147483637"
+gdb_test "p lbound(array_1d_4bytes_overflow)" "= \\(2147483644\\)"
+
# Ensure we reached the final breakpoint. If more tests have been added
# to the test script, and this starts failing, then the safety 'while'
# loop above might need to be increased.
-gdb_assert {$found_final_breakpoint} "reached final breakpoint"
+gdb_continue_to_breakpoint "Final Breakpoint"
# Now for some final tests. This is mostly testing that GDB gives the
# correct errors in certain cases.
diff --git a/gdb/testsuite/gdb.fortran/size.exp b/gdb/testsuite/gdb.fortran/size.exp
index 81b5840..fb49e28 100644
--- a/gdb/testsuite/gdb.fortran/size.exp
+++ b/gdb/testsuite/gdb.fortran/size.exp
@@ -29,28 +29,33 @@ if ![fortran_runto_main] {
return -1
}
-gdb_breakpoint [gdb_get_line_number "Test Breakpoint"]
+gdb_breakpoint [gdb_get_line_number "Test Breakpoint 1"]
+gdb_breakpoint [gdb_get_line_number "Test Breakpoint 2"]
+gdb_breakpoint [gdb_get_line_number "Test Breakpoint 3"]
+gdb_breakpoint [gdb_get_line_number "Test Breakpoint 4"]
+
+gdb_breakpoint [gdb_get_line_number "Breakpoint before deallocate\."]
gdb_breakpoint [gdb_get_line_number "Final Breakpoint"]
# We place a limit on the number of tests that can be run, just in
# case something goes wrong, and GDB gets stuck in an loop here.
-set found_final_breakpoint false
+set found_dealloc_breakpoint false
set test_count 0
-while { $test_count < 500 } {
+while { $test_count < 600 } {
with_test_prefix "test $test_count" {
incr test_count
gdb_test_multiple "continue" "continue" {
- -re -wrap "! Test Breakpoint" {
+ -re -wrap "! Test Breakpoint \[0-9\]" {
# We can run a test from here.
}
- -re -wrap "! Final Breakpoint" {
+ -re -wrap "! Breakpoint before deallocate\." {
# We're done with the tests.
- set found_final_breakpoint true
+ set found_dealloc_breakpoint true
}
}
- if ($found_final_breakpoint) {
+ if ($found_dealloc_breakpoint) {
break
}
@@ -61,26 +66,81 @@ while { $test_count < 500 } {
# as a test.
set command ""
gdb_test_multiple "up" "up" {
- -re -wrap "\r\n\[0-9\]+\[ \t\]+call test_size \\((\[^\r\n\]+)\\)" {
+ -re -wrap "\r\n\[0-9\]+\[ \t\]+call test_size_\[0-9\]* \\((\[^\r\n\]+)\\)" {
set command $expect_out(1,string)
}
}
gdb_assert { ![string equal $command ""] } "found a command to run"
- gdb_test "p $command" " = $answer"
+ gdb_test_multiple "p $command" "p $command" {
+ -re -wrap " = $answer" {
+ pass $gdb_test_name
+ }
+ -re -wrap "SIZE can only be applied to arrays" {
+ # Because of ifort's DWARF pointer representation we need to
+ # aditionally de-reference Fortran pointers.
+ regsub -all "\\(" $command "\(\*" command_deref
+ gdb_test "p $command_deref" " = $answer"
+ pass $gdb_test_name
+ }
+ }
+ }
+}
+
+# Since the behavior of size (array_1d, 2) differs for different compilers and
+# neither of them seem to behave as expected (gfortran prints apparently random
+# things, ifort would print 0), we test for GDB's error message instead.
+gdb_assert {$found_dealloc_breakpoint} "ran all compiled in tests"
+
+foreach var {array_1d_p array_2d_p allocatable_array_1d \
+ allocatable_array_2d} {
+ gdb_test_multiple "p size ($var, 3)" "p size ($var, 3)" {
+ -re -wrap "DIM argument to SIZE must be between 1 and \[1-2\]" {
+ pass $gdb_test_name
+ }
+ -re -wrap "SIZE can only be applied to arrays" {
+ # Because of ifort's DWARF pointer representation we need to
+ # aditionally de-reference Fortran pointers.
+ gdb_test "p size (*$var, 3)" \
+ "DIM argument to SIZE must be between 1 and \[1-2\]"
+ pass $gdb_test_name
+ }
}
}
+# For wrong kind parameters GBD and compiler behavior differs. Here,
+# gfortran/ifort/ifx would already throw a compiler error - a user might still
+# try and call size with something like -3 as kind parameter, so we test GDB's
+# error handling here.
+
+foreach var {array_1d_p array_2d_p allocatable_array_1d \
+ allocatable_array_2d} {
+ gdb_test "p size ($var, 1, -10)" \
+ "unsupported kind -10 for type integer\\*4"
+ gdb_test "p size ($var, 1, 123)" \
+ "unsupported kind 123 for type integer\\*4"
+}
+
# Ensure we reached the final breakpoint. If more tests have been added
# to the test script, and this starts failing, then the safety 'while'
# loop above might need to be increased.
-gdb_assert {$found_final_breakpoint} "ran all compiled in tests"
+gdb_continue_to_breakpoint "Final Breakpoint"
foreach var {array_1d_p array_2d_p allocatable_array_1d \
allocatable_array_2d} {
- gdb_test "p size ($var)" \
- "SIZE can only be used on allocated/associated arrays"
+ gdb_test_multiple "p size ($var)" "p size ($var)" {
+ -re -wrap "SIZE can only be used on allocated/associated arrays" {
+ pass $gdb_test_name
+ }
+ -re -wrap "SIZE can only be applied to arrays" {
+ # Because of ifort's DWARF pointer representation we need to
+ # aditionally de-reference Fortran pointers.
+ gdb_test "p size (*$var)" \
+ "Attempt to take contents of a not associated pointer\."
+ pass $gdb_test_name
+ }
+ }
}
foreach var {an_integer a_real} {
diff --git a/gdb/testsuite/gdb.fortran/size.f90 b/gdb/testsuite/gdb.fortran/size.f90
index 76f71ab..c924d84 100644
--- a/gdb/testsuite/gdb.fortran/size.f90
+++ b/gdb/testsuite/gdb.fortran/size.f90
@@ -28,74 +28,184 @@ program test
integer, allocatable :: allocatable_array_1d (:)
integer, allocatable :: allocatable_array_2d (:,:)
+ integer, parameter :: b1_o = 127 + 1
+ integer, parameter :: b2_o = 32767 + 3
+ integer*8, parameter :: b4_o = 2147483647 + 5
+
+ integer, allocatable :: array_1d_1byte_overflow (:)
+ integer, allocatable :: array_1d_2bytes_overflow (:)
+ integer, allocatable :: array_1d_4bytes_overflow (:)
+ integer, allocatable :: array_2d_1byte_overflow (:,:)
+ integer, allocatable :: array_2d_2bytes_overflow (:,:)
+ integer, allocatable :: array_3d_1byte_overflow (:,:,:)
+
! Loop counters.
integer :: s1, s2
+ allocate (array_1d_1byte_overflow (1:b1_o))
+ allocate (array_1d_2bytes_overflow (1:b2_o))
+ allocate (array_1d_4bytes_overflow (1:b4_o))
+
+ allocate (array_2d_1byte_overflow (1:b1_o, 1:b1_o))
+ allocate (array_2d_2bytes_overflow (1:b2_o, 1:b2_o))
+
+ allocate (array_3d_1byte_overflow (1:b1_o, 1:b1_o, 1:b1_o))
+
+
! The start of the tests.
- call test_size (size (array_1d))
- call test_size (size (array_1d, 1))
+ call test_size_4 (size (array_1d))
+ call test_size_4 (size (array_1d, 1))
do s1=1, SIZE (array_1d, 1), 1
- call test_size (size (array_1d (1:10:s1)))
- call test_size (size (array_1d (1:10:s1), 1))
- call test_size (size (array_1d (10:1:-s1)))
- call test_size (size (array_1d (10:1:-s1), 1))
+ call test_size_4 (size (array_1d (1:10:s1)))
+ call test_size_4 (size (array_1d (1:10:s1), 1))
+ call test_size_4 (size (array_1d (10:1:-s1)))
+ call test_size_4 (size (array_1d (10:1:-s1), 1))
end do
do s2=1, SIZE (array_2d, 2), 1
do s1=1, SIZE (array_2d, 1), 1
- call test_size (size (array_2d (1:4:s1, 1:3:s2)))
- call test_size (size (array_2d (4:1:-s1, 1:3:s2)))
- call test_size (size (array_2d (1:4:s1, 3:1:-s2)))
- call test_size (size (array_2d (4:1:-s1, 3:1:-s2)))
-
- call test_size (size (array_2d (1:4:s1, 1:3:s2), 1))
- call test_size (size (array_2d (4:1:-s1, 1:3:s2), 1))
- call test_size (size (array_2d (1:4:s1, 3:1:-s2), 1))
- call test_size (size (array_2d (4:1:-s1, 3:1:-s2), 1))
-
- call test_size (size (array_2d (1:4:s1, 1:3:s2), 2))
- call test_size (size (array_2d (4:1:-s1, 1:3:s2), 2))
- call test_size (size (array_2d (1:4:s1, 3:1:-s2), 2))
- call test_size (size (array_2d (4:1:-s1, 3:1:-s2), 2))
+ call test_size_4 (size (array_2d (1:4:s1, 1:3:s2)))
+ call test_size_4 (size (array_2d (4:1:-s1, 1:3:s2)))
+ call test_size_4 (size (array_2d (1:4:s1, 3:1:-s2)))
+ call test_size_4 (size (array_2d (4:1:-s1, 3:1:-s2)))
+
+ call test_size_4 (size (array_2d (1:4:s1, 1:3:s2), 1))
+ call test_size_4 (size (array_2d (4:1:-s1, 1:3:s2), 1))
+ call test_size_4 (size (array_2d (1:4:s1, 3:1:-s2), 1))
+ call test_size_4 (size (array_2d (4:1:-s1, 3:1:-s2), 1))
+
+ call test_size_4 (size (array_2d (1:4:s1, 1:3:s2), 2))
+ call test_size_4 (size (array_2d (4:1:-s1, 1:3:s2), 2))
+ call test_size_4 (size (array_2d (1:4:s1, 3:1:-s2), 2))
+ call test_size_4 (size (array_2d (4:1:-s1, 3:1:-s2), 2))
end do
end do
allocate (allocatable_array_1d (-10:-5))
- call test_size (size (allocatable_array_1d))
+ call test_size_4 (size (allocatable_array_1d))
do s1=1, SIZE (allocatable_array_1d, 1), 1
- call test_size (size (allocatable_array_1d (-10:-5:s1)))
- call test_size (size (allocatable_array_1d (-5:-10:-s1)))
+ call test_size_4 (size (allocatable_array_1d (-10:-5:s1)))
+ call test_size_4 (size (allocatable_array_1d (-5:-10:-s1)))
- call test_size (size (allocatable_array_1d (-10:-5:s1), 1))
- call test_size (size (allocatable_array_1d (-5:-10:-s1), 1))
+ call test_size_4 (size (allocatable_array_1d (-10:-5:s1), 1))
+ call test_size_4 (size (allocatable_array_1d (-5:-10:-s1), 1))
end do
allocate (allocatable_array_2d (-3:3, 8:12))
do s2=1, SIZE (allocatable_array_2d, 2), 1
do s1=1, SIZE (allocatable_array_2d, 1), 1
- call test_size (size (allocatable_array_2d (-3:3:s1, 8:12:s2)))
- call test_size (size (allocatable_array_2d (3:-3:-s1, 8:12:s2)))
- call test_size (size (allocatable_array_2d (-3:3:s1, 12:8:-s2)))
- call test_size (size (allocatable_array_2d (3:-3:-s1, 12:8:-s2)))
-
- call test_size (size (allocatable_array_2d (-3:3:s1, 8:12:s2), 1))
- call test_size (size (allocatable_array_2d (3:-3:-s1, 8:12:s2), 2))
- call test_size (size (allocatable_array_2d (-3:3:s1, 12:8:-s2), 1))
- call test_size (size (allocatable_array_2d (3:-3:-s1, 12:8:-s2), 2))
+ call test_size_4 (size (allocatable_array_2d (-3:3:s1, 8:12:s2)))
+ call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 8:12:s2)))
+ call test_size_4 (size (allocatable_array_2d (-3:3:s1, 12:8:-s2)))
+ call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 12:8:-s2)))
+
+ call test_size_4 (size (allocatable_array_2d (-3:3:s1, 8:12:s2), 1))
+ call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 8:12:s2), 2))
+ call test_size_4 (size (allocatable_array_2d (-3:3:s1, 12:8:-s2), 1))
+ call test_size_4 (size (allocatable_array_2d (3:-3:-s1, 12:8:-s2), 2))
end do
end do
array_1d_p => array_1d
- call test_size (size (array_1d_p))
- call test_size (size (array_1d_p, 1))
+ call test_size_4 (size (array_1d_p))
+ call test_size_4 (size (array_1d_p, 1))
array_2d_p => array_2d
- call test_size (size (array_2d_p))
- call test_size (size (array_2d_p, 1))
- call test_size (size (array_2d_p, 2))
+ call test_size_4 (size (array_2d_p))
+ call test_size_4 (size (array_2d_p, 1))
+ call test_size_4 (size (array_2d_p, 2))
+
+ ! Test kind parameters - compiler requires these to be compile time constant
+ ! so sadly there cannot be a loop over the kinds 1, 2, 4, 8.
+ call test_size_4 (size (array_1d_1byte_overflow))
+ call test_size_4 (size (array_1d_2bytes_overflow))
+
+ call test_size_4 (size (array_1d_1byte_overflow, 1))
+ call test_size_4 (size (array_1d_2bytes_overflow, 1))
+
+ call test_size_4 (size (array_1d_4bytes_overflow))
+ call test_size_4 (size (array_1d_4bytes_overflow, 1))
+
+ call test_size_4 (size (array_2d_1byte_overflow, 1))
+ call test_size_4 (size (array_2d_1byte_overflow, 2))
+ call test_size_4 (size (array_2d_2bytes_overflow, 1))
+ call test_size_4 (size (array_2d_2bytes_overflow, 2))
+
+ call test_size_4 (size (array_3d_1byte_overflow, 1))
+ call test_size_4 (size (array_3d_1byte_overflow, 2))
+ call test_size_4 (size (array_3d_1byte_overflow, 3))
+
+ ! Kind 1.
+
+ call test_size_1 (size (array_1d_1byte_overflow, 1, 1))
+ call test_size_1 (size (array_1d_2bytes_overflow, 1, 1))
+ call test_size_1 (size (array_1d_4bytes_overflow, 1, 1))
+
+ call test_size_1 (size (array_2d_1byte_overflow, 1, 1))
+ call test_size_1 (size (array_2d_1byte_overflow, 2, 1))
+ call test_size_1 (size (array_2d_2bytes_overflow, 1, 1))
+ call test_size_1 (size (array_2d_2bytes_overflow, 2, 1))
+
+ call test_size_1 (size (array_3d_1byte_overflow, 1, 1))
+ call test_size_1 (size (array_3d_1byte_overflow, 2, 1))
+ call test_size_1 (size (array_3d_1byte_overflow, 3, 1))
+
+ ! Kind 2.
+ call test_size_2 (size (array_1d_1byte_overflow, 1, 2))
+ call test_size_2 (size (array_1d_2bytes_overflow, 1, 2))
+ call test_size_2 (size (array_1d_4bytes_overflow, 1, 2))
+
+ call test_size_2 (size (array_2d_1byte_overflow, 1, 2))
+ call test_size_2 (size (array_2d_1byte_overflow, 2, 2))
+ call test_size_2 (size (array_2d_2bytes_overflow, 1, 2))
+ call test_size_2 (size (array_2d_2bytes_overflow, 2, 2))
+
+ call test_size_2 (size (array_3d_1byte_overflow, 1, 2))
+ call test_size_2 (size (array_3d_1byte_overflow, 2, 2))
+ call test_size_2 (size (array_3d_1byte_overflow, 3, 2))
+
+ ! Kind 4.
+ call test_size_4 (size (array_1d_1byte_overflow, 1, 4))
+ call test_size_4 (size (array_1d_2bytes_overflow, 1, 4))
+ call test_size_4 (size (array_1d_4bytes_overflow, 1, 4))
+
+ call test_size_4 (size (array_2d_1byte_overflow, 1, 4))
+ call test_size_4 (size (array_2d_1byte_overflow, 2, 4))
+ call test_size_4 (size (array_2d_2bytes_overflow, 1, 4))
+ call test_size_4 (size (array_2d_2bytes_overflow, 2, 4))
+
+ call test_size_4 (size (array_3d_1byte_overflow, 1, 4))
+ call test_size_4 (size (array_3d_1byte_overflow, 2, 4))
+ call test_size_4 (size (array_3d_1byte_overflow, 3, 4))
+
+ ! Kind 8.
+ call test_size_8 (size (array_1d_1byte_overflow, 1, 8))
+ call test_size_8 (size (array_1d_2bytes_overflow, 1, 8))
+ call test_size_8 (size (array_1d_4bytes_overflow, 1, 8))
+
+ call test_size_8 (size (array_2d_1byte_overflow, 1, 8))
+ call test_size_8 (size (array_2d_1byte_overflow, 2, 8))
+ call test_size_8 (size (array_2d_2bytes_overflow, 1, 8))
+ call test_size_8 (size (array_2d_2bytes_overflow, 2, 8))
+
+ call test_size_8 (size (array_3d_1byte_overflow, 1, 8))
+ call test_size_8 (size (array_3d_1byte_overflow, 2, 8))
+ call test_size_8 (size (array_3d_1byte_overflow, 3, 8))
+
+ print *, "" ! Breakpoint before deallocate.
deallocate (allocatable_array_1d)
deallocate (allocatable_array_2d)
+
+ deallocate (array_3d_1byte_overflow)
+
+ deallocate (array_2d_2bytes_overflow)
+ deallocate (array_2d_1byte_overflow)
+
+ deallocate (array_1d_4bytes_overflow)
+ deallocate (array_1d_2bytes_overflow)
+ deallocate (array_1d_1byte_overflow)
+
array_1d_p => null ()
array_2d_p => null ()
@@ -108,11 +218,28 @@ program test
print *, allocated (allocatable_array_2d)
contains
+ subroutine test_size_1 (answer)
+ integer*1 :: answer
+
+ print *, answer ! Test Breakpoint 1
+ end subroutine test_size_1
+
+ subroutine test_size_2 (answer)
+ integer*2 :: answer
+
+ print *, answer ! Test Breakpoint 2
+ end subroutine test_size_2
+
+ subroutine test_size_4 (answer)
+ integer*4 :: answer
+
+ print *, answer ! Test Breakpoint 3
+ end subroutine test_size_4
- subroutine test_size (answer)
- integer :: answer
+ subroutine test_size_8 (answer)
+ integer*8 :: answer
- print *,answer ! Test Breakpoint
- end subroutine test_size
+ print *, answer ! Test Breakpoint 4
+ end subroutine test_size_8
end program test