Commit | Line | Data |
---|---|---|
88b9d363 | 1 | # Copyright 2018-2022 Free Software Foundation, Inc. |
23be8da7 RB |
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 | if {[skip_fortran_tests]} { return -1 } | |
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"]]} then { | |
29 | perror "couldn't run to breakpoint post_truth_table_init" | |
30 | continue | |
31 | } | |
32 | ||
7b63ad86 RB |
33 | # Non-zero value to use as the function call count base. Using zero is avoided |
34 | # as this is a common value in memory. | |
35 | set prime 17 | |
36 | ||
37 | # Reset all call counts to the initial value ($prime). | |
38 | proc reset_called_flags { } { | |
39 | global prime | |
40 | foreach counter {no_arg no_arg_false one_arg two_arg array} { | |
41 | gdb_test_no_output "set var calls%function_${counter}_called=$prime" | |
42 | } | |
43 | } | |
44 | ||
45 | reset_called_flags | |
46 | ||
23be8da7 RB |
47 | # Vary conditional and input over the standard truth table. |
48 | # Test that the debugger can evaluate expressions of the form | |
49 | # a(x,y) .OR./.AND. a(a,b) correctly. | |
50 | foreach_with_prefix truth_table_index {1 2 3 4} { | |
51 | gdb_test "p truth_table($truth_table_index, 1) .OR. truth_table($truth_table_index, 2)" \ | |
52 | "[expr $truth_table_index > 1 ? \".TRUE.\" : \".FALSE.\"]" | |
53 | } | |
54 | ||
55 | foreach_with_prefix truth_table_index {1 2 3 4} { | |
56 | gdb_test "p truth_table($truth_table_index, 1) .AND. truth_table($truth_table_index, 2)" \ | |
57 | "[expr $truth_table_index > 3 ? \".TRUE.\" : \".FALSE.\"]" | |
58 | } | |
59 | ||
60 | # Vary number of function arguments to skip. | |
61 | set argument_list "" | |
62 | foreach_with_prefix arg {"No" "One" "Two"} { | |
63 | set trimmed_args [string trimright $argument_list ,] | |
64 | set arg_lower [string tolower $arg] | |
65 | gdb_test "p function_no_arg_false() .OR. function_${arg_lower}_arg($trimmed_args)" \ | |
7b63ad86 RB |
66 | " = .TRUE." |
67 | reset_called_flags | |
23be8da7 | 68 | gdb_test "p .TRUE. .OR. function_${arg_lower}_arg($trimmed_args)" \ |
7b63ad86 RB |
69 | " = .TRUE." |
70 | # Check that none of the short-circuited functions have been called. | |
71 | gdb_test "p calls" \ | |
72 | " = \\\( 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 \\\)" | |
23be8da7 RB |
73 | append argument_list " .TRUE.," |
74 | } | |
75 | ||
7b63ad86 RB |
76 | with_test_prefix "nested call not skipped" { |
77 | reset_called_flags | |
78 | # Check nested calls | |
79 | gdb_test "p function_one_arg(.FALSE. .OR. function_no_arg())" \ | |
80 | " = .TRUE." | |
81 | gdb_test "p calls" \ | |
82 | " = \\\( 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 \\\)" | |
83 | } | |
23be8da7 | 84 | |
7b63ad86 RB |
85 | with_test_prefix "nested call skipped" { |
86 | gdb_test "p function_one_arg(.TRUE. .OR. function_no_arg())" \ | |
87 | " = .TRUE." | |
88 | gdb_test "p calls" \ | |
89 | " = \\\( 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 \\\)" | |
90 | } | |
23be8da7 RB |
91 | |
92 | # Vary number of components in the expression to skip. | |
93 | set expression "p .TRUE." | |
94 | foreach_with_prefix expression_components {1 2 3 4} { | |
95 | set expression "$expression .OR. function_one_arg(.TRUE.)" | |
96 | gdb_test "$expression" \ | |
7b63ad86 | 97 | " = .TRUE." |
23be8da7 RB |
98 | } |
99 | ||
100 | # Check parsing skipped substring operations. | |
7b63ad86 | 101 | gdb_test "p .TRUE. .OR. binary_string(1)" " = .TRUE." |
23be8da7 RB |
102 | |
103 | # Check parsing skipped substring operations with ranges. These should all | |
104 | # return true as the result is > 0. | |
105 | # The second binary_string access is important as an incorrect pos update | |
106 | # will not be picked up by a single access. | |
107 | foreach_with_prefix range1 {"1:2" ":" ":2" "1:"} { | |
108 | foreach_with_prefix range2 {"1:2" ":" ":2" "1:"} { | |
109 | gdb_test "p .TRUE. .OR. binary_string($range1) .OR. binary_string($range2)" \ | |
7b63ad86 | 110 | " = .TRUE." |
23be8da7 RB |
111 | } |
112 | } | |
113 | ||
114 | # Skip multi-dimensional arrays with ranges. | |
115 | foreach_with_prefix range1 {"1:2" ":" ":2" "1:"} { | |
116 | foreach_with_prefix range2 {"1:2" ":" ":2" "1:"} { | |
117 | gdb_test "p .TRUE. .OR. binary_string($range1) .OR. truth_table($range2, 1)" \ | |
7b63ad86 | 118 | " = .TRUE." |
23be8da7 RB |
119 | } |
120 | } | |
121 | ||
122 | # Check evaluation of substring operations in logical expressions. | |
7b63ad86 RB |
123 | gdb_test "p .FALSE. .OR. binary_string(1)" " = .FALSE." |
124 | ||
125 | with_test_prefix "binary string skip" { | |
126 | reset_called_flags | |
127 | # Function call and substring skip. | |
128 | gdb_test "p .TRUE. .OR. function_one_arg(binary_string(1))" \ | |
129 | " = .TRUE." | |
130 | gdb_test "p calls%function_one_arg_called" " = $prime" | |
131 | } | |
23be8da7 | 132 | |
7b63ad86 RB |
133 | with_test_prefix "array skip" { |
134 | # Function call and array skip. | |
135 | reset_called_flags | |
136 | gdb_test "p .TRUE. .OR. function_array(binary_string)" \ | |
137 | " = .TRUE." | |
138 | gdb_test "p calls%function_array_called" " = $prime" | |
139 | } |