1 # Copyright 2018-2024 Free Software Foundation, Inc. 2 3 # This program is free software; you can redistribute it and/or modify 4 # it under the terms of the GNU General Public License as published by 5 # the Free Software Foundation; either version 3 of the License, or 6 # (at your option) any later version. 7 # 8 # This program is distributed in the hope that it will be useful, 9 # but WITHOUT ANY WARRANTY; without even the implied warranty of 10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 # GNU General Public License for more details. 12 # 13 # You should have received a copy of the GNU General Public License 14 # along with this program. If not, see <http://www.gnu.org/licenses/> . 15 16 # Test evaluating logical expressions that contain array references, function 17 # calls and substring operations that are to be skipped due to short 18 # circuiting. 19 20 require allow_fortran_tests 21 22 standard_testfile ".f90" 23 24 if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} {debug f90}]} { 25 return -1 26 } 27 28 if {![runto [gdb_get_line_number "post_truth_table_init"]]} { 29 return 30 } 31 32 # Non-zero value to use as the function call count base. Using zero is avoided 33 # as this is a common value in memory. 34 set prime 17 35 36 # Reset all call counts to the initial value ($prime). 37 proc reset_called_flags { } { 38 global prime 39 foreach counter {no_arg no_arg_false one_arg two_arg array} { 40 gdb_test_no_output "set var calls%function_${counter}_called=$prime" 41 } 42 } 43 44 reset_called_flags 45 46 # Vary conditional and input over the standard truth table. 47 # Test that the debugger can evaluate expressions of the form 48 # a(x,y) .OR./.AND. a(a,b) correctly. 49 foreach_with_prefix truth_table_index {1 2 3 4} { 50 gdb_test "p truth_table($truth_table_index, 1) .OR. truth_table($truth_table_index, 2)" \ 51 "[expr $truth_table_index > 1 ? \".TRUE.\" : \".FALSE.\"]" 52 } 53 54 foreach_with_prefix truth_table_index {1 2 3 4} { 55 gdb_test "p truth_table($truth_table_index, 1) .AND. truth_table($truth_table_index, 2)" \ 56 "[expr $truth_table_index > 3 ? \".TRUE.\" : \".FALSE.\"]" 57 } 58 59 # Vary number of function arguments to skip. 60 set argument_list "" 61 foreach_with_prefix arg {"No" "One" "Two"} { 62 set trimmed_args [string trimright $argument_list ,] 63 set arg_lower [string tolower $arg] 64 gdb_test "p function_no_arg_false() .OR. function_${arg_lower}_arg($trimmed_args)" \ 65 " = .TRUE." 66 reset_called_flags 67 gdb_test "p .TRUE. .OR. function_${arg_lower}_arg($trimmed_args)" \ 68 " = .TRUE." 69 # Check that none of the short-circuited functions have been called. 70 gdb_test "p calls" \ 71 " = \\\( function_no_arg_called = $prime, function_no_arg_false_called = $prime, function_one_arg_called = $prime, function_two_arg_called = $prime, function_array_called = $prime \\\)" 72 append argument_list " .TRUE.," 73 } 74 75 with_test_prefix "nested call not skipped" { 76 reset_called_flags 77 # Check nested calls 78 gdb_test "p function_one_arg(.FALSE. .OR. function_no_arg())" \ 79 " = .TRUE." 80 gdb_test "p calls" \ 81 " = \\\( function_no_arg_called = [expr $prime + 1], function_no_arg_false_called = $prime, function_one_arg_called = [expr $prime + 1], function_two_arg_called = $prime, function_array_called = $prime \\\)" 82 } 83 84 with_test_prefix "nested call skipped" { 85 gdb_test "p function_one_arg(.TRUE. .OR. function_no_arg())" \ 86 " = .TRUE." 87 gdb_test "p calls" \ 88 " = \\\( function_no_arg_called = [expr $prime + 1], function_no_arg_false_called = $prime, function_one_arg_called = [expr $prime + 2], function_two_arg_called = $prime, function_array_called = $prime \\\)" 89 } 90 91 # Vary number of components in the expression to skip. 92 set expression "p .TRUE." 93 foreach_with_prefix expression_components {1 2 3 4} { 94 set expression "$expression .OR. function_one_arg(.TRUE.)" 95 gdb_test "$expression" \ 96 " = .TRUE." 97 } 98 99 # Check parsing skipped substring operations. 100 gdb_test "p .TRUE. .OR. binary_string(1)" " = .TRUE." 101 102 # Check parsing skipped substring operations with ranges. These should all 103 # return true as the result is > 0. 104 # The second binary_string access is important as an incorrect pos update 105 # will not be picked up by a single access. 106 foreach_with_prefix range1 {"1:2" ":" ":2" "1:"} { 107 foreach_with_prefix range2 {"1:2" ":" ":2" "1:"} { 108 gdb_test "p .TRUE. .OR. binary_string($range1) .OR. binary_string($range2)" \ 109 " = .TRUE." 110 } 111 } 112 113 # Skip multi-dimensional arrays with ranges. 114 foreach_with_prefix range1 {"1:2" ":" ":2" "1:"} { 115 foreach_with_prefix range2 {"1:2" ":" ":2" "1:"} { 116 gdb_test "p .TRUE. .OR. binary_string($range1) .OR. truth_table($range2, 1)" \ 117 " = .TRUE." 118 } 119 } 120 121 # Check evaluation of substring operations in logical expressions. 122 gdb_test "p .FALSE. .OR. binary_string(1)" " = .FALSE." 123 124 with_test_prefix "binary string skip" { 125 reset_called_flags 126 # Function call and substring skip. 127 gdb_test "p .TRUE. .OR. function_one_arg(binary_string(1))" \ 128 " = .TRUE." 129 gdb_test "p calls%function_one_arg_called" " = $prime" 130 } 131 132 with_test_prefix "array skip" { 133 # Function call and array skip. 134 reset_called_flags 135 gdb_test "p .TRUE. .OR. function_array(binary_string)" \ 136 " = .TRUE." 137 gdb_test "p calls%function_array_called" " = $prime" 138 } 139
Indexes created Tue May 05 00:25:04 UTC 2026