diff options
author | Nils-Christian Kempke <nils-christian.kempke@intel.com> | 2022-04-11 14:06:56 +0200 |
---|---|---|
committer | Nils-Christian Kempke <nils-christian.kempke@intel.com> | 2022-04-11 14:06:56 +0200 |
commit | 891e4190ba705373eec7b374209478215fff5401 (patch) | |
tree | 5d73fbd42f1e723066910ce02db03e4a27482c07 /gdb/testsuite/gdb.fortran | |
parent | 04ba65365054e37461b4fd904ff9c00d88023b02 (diff) | |
download | gdb-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.exp | 46 | ||||
-rw-r--r-- | gdb/testsuite/gdb.fortran/lbound-ubound.F90 | 49 | ||||
-rw-r--r-- | gdb/testsuite/gdb.fortran/lbound-ubound.exp | 29 | ||||
-rw-r--r-- | gdb/testsuite/gdb.fortran/size.exp | 84 | ||||
-rw-r--r-- | gdb/testsuite/gdb.fortran/size.f90 | 213 |
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 |