Commit | Line | Data |
---|---|---|
68622837 SS |
1 | # Copyright (C) 1994 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 2 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, write to the Free Software | |
15 | # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ | |
16 | ||
17 | # Please email any bugs, comments, and/or additions to this file to: | |
18 | # bug-gdb@prep.ai.mit.edu | |
19 | ||
20 | # This file was adapted from Chill tests by Stan Shebs (shebs@cygnus.com). | |
21 | ||
22 | if $tracelevel then { | |
23 | strace $tracelevel | |
24 | } | |
25 | ||
26 | set prms_id 0 | |
27 | set bug_id 0 | |
28 | ||
29 | # Set the current language to fortran. This counts as a test. If it | |
30 | # fails, then we skip the other tests. | |
31 | ||
32 | proc set_lang_fortran {} { | |
33 | global prompt | |
34 | ||
35 | send "set language fortran\n" | |
36 | expect { | |
37 | -re ".*$prompt $" {} | |
38 | timeout { fail "set language fortran (timeout)" ; return 0 } | |
39 | } | |
40 | ||
41 | send "show language\n" | |
42 | expect { | |
43 | -re ".* source language is \"fortran\".*$prompt $" { | |
44 | pass "set language to \"fortran\"" | |
45 | return 1 | |
46 | } | |
47 | -re ".*$prompt $" { | |
48 | fail "setting language to \"fortran\"" | |
49 | return 0 | |
50 | } | |
51 | timeout { | |
52 | fail "can't show language (timeout)" | |
53 | return 0 | |
54 | } | |
55 | } | |
56 | } | |
57 | ||
58 | # Testing printing of a specific value. Increment passcount for | |
59 | # success or issue fail message for failure. In both cases, return | |
60 | # a 1 to indicate that more tests can proceed. However a timeout | |
61 | # is a serious error, generates a special fail message, and causes | |
62 | # a 0 to be returned to indicate that more tests are likely to fail | |
63 | # as well. | |
64 | # | |
65 | # Args are: | |
66 | # | |
67 | # First one is string to send to gdb | |
68 | # Second one is string to match gdb result to | |
69 | # Third one is an optional message to be printed | |
70 | ||
71 | proc test_print_accept { args } { | |
72 | global prompt | |
73 | global passcount | |
74 | global verbose | |
75 | ||
76 | if [llength $args]==3 then { | |
77 | set message [lindex $args 2] | |
78 | } else { | |
79 | set message [lindex $args 0] | |
80 | } | |
81 | set sendthis [lindex $args 0] | |
82 | set expectthis [lindex $args 1] | |
83 | if $verbose>2 then { | |
84 | send_user "Sending \"$sendthis\" to gdb\n" | |
85 | send_user "Looking to match \"$expectthis\"\n" | |
86 | send_user "Message is \"$message\"\n" | |
87 | } | |
88 | send "$sendthis\n" | |
89 | expect { | |
90 | -re ".* = $expectthis\r\n$prompt $" { | |
91 | incr passcount | |
92 | return 1 | |
93 | } | |
94 | -re ".*$prompt $" { | |
95 | if ![string match "" $message] then { | |
96 | fail "$sendthis ($message)" | |
97 | } else { | |
98 | fail "$sendthis" | |
99 | } | |
100 | return 1 | |
101 | } | |
102 | timeout { | |
103 | fail "$sendthis (timeout)" | |
104 | return 0 | |
105 | } | |
106 | } | |
107 | } | |
108 | ||
109 | # Testing printing of a specific value. Increment passcount for | |
110 | # success or issue fail message for failure. In both cases, return | |
111 | # a 1 to indicate that more tests can proceed. However a timeout | |
112 | # is a serious error, generates a special fail message, and causes | |
113 | # a 0 to be returned to indicate that more tests are likely to fail | |
114 | # as well. | |
115 | ||
116 | proc test_print_reject { args } { | |
117 | global prompt | |
118 | global passcount | |
119 | global verbose | |
120 | ||
121 | if [llength $args]==2 then { | |
122 | set expectthis [lindex $args 1] | |
123 | } else { | |
124 | set expectthis "should never match this bogus string" | |
125 | } | |
126 | set sendthis [lindex $args 0] | |
127 | if $verbose>2 then { | |
128 | send_user "Sending \"$sendthis\" to gdb\n" | |
129 | send_user "Looking to match \"$expectthis\"\n" | |
130 | } | |
131 | send "$sendthis\n" | |
132 | expect { | |
133 | -re ".*A .* in expression.*\\.*$prompt $" { | |
134 | incr passcount | |
135 | return 1 | |
136 | } | |
137 | -re ".*Junk after end of expression.*$prompt $" { | |
138 | incr passcount | |
139 | return 1 | |
140 | } | |
141 | -re ".*No symbol table is loaded.*$prompt $" { | |
142 | incr passcount | |
143 | return 1 | |
144 | } | |
145 | -re ".*$expectthis.*$prompt $" { | |
146 | incr passcount | |
147 | return 1 | |
148 | } | |
149 | -re ".*$prompt $" { | |
150 | fail "$sendthis not properly rejected" | |
151 | return 1 | |
152 | } | |
153 | timeout { | |
154 | fail "$sendthis (timeout)" | |
155 | return 0 | |
156 | } | |
157 | } | |
158 | } | |
159 | ||
160 | proc test_integer_literal_types_accepted {} { | |
161 | global prompt | |
162 | global passcount | |
163 | ||
164 | set passcount 0 | |
165 | ||
166 | # Test various decimal values. | |
167 | ||
168 | test_print_accept "pt 123" "integer" | |
169 | ||
170 | if $passcount then { | |
171 | pass "$passcount correct integer literal types printed" | |
172 | } | |
173 | } | |
174 | ||
175 | proc test_character_literal_types_accepted {} { | |
176 | global prompt | |
177 | global passcount | |
178 | ||
179 | set passcount 0 | |
180 | ||
181 | # Test various character values. | |
182 | ||
183 | test_print_accept "pt 'a'" "character*1" | |
184 | ||
185 | if $passcount then { | |
186 | pass "$passcount correct character literal types printed" | |
187 | } | |
188 | } | |
189 | ||
190 | proc test_integer_literal_types_rejected {} { | |
191 | global prompt | |
192 | global passcount | |
193 | ||
194 | set passcount 0 | |
195 | ||
196 | test_print_reject "pt _" | |
197 | ||
198 | if $passcount then { | |
199 | pass "$passcount incorrect integer literal types rejected" | |
200 | } | |
201 | } | |
202 | ||
203 | proc test_logical_literal_types_accepted {} { | |
204 | global prompt | |
205 | global passcount | |
206 | ||
207 | set passcount 0 | |
208 | ||
209 | # Test the only possible values for a logical, TRUE and FALSE. | |
210 | ||
211 | test_print_accept "pt .TRUE." "logical*2" | |
212 | test_print_accept "pt .FALSE." "logical*2" | |
213 | ||
214 | if $passcount then { | |
215 | pass "$passcount correct logical literal types printed" | |
216 | } | |
217 | } | |
218 | ||
219 | proc test_float_literal_types_accepted {} { | |
220 | global prompt | |
221 | global passcount | |
222 | ||
223 | set passcount 0 | |
224 | ||
225 | # Test various floating point formats | |
226 | ||
227 | test_print_accept "pt .44" "real*8" | |
228 | test_print_accept "pt 44.0" "real*8" | |
229 | test_print_accept "pt 10D20" "1" | |
230 | test_print_accept "pt 10D20" "0" | |
231 | test_print_accept "pt 10d20" "1" | |
232 | test_print_accept "pt 10d20" "0" | |
233 | test_print_accept "pt 10E20" "real*8" | |
234 | test_print_accept "pt 10E20" "real*8" | |
235 | test_print_accept "pt 10e20" "real*8" | |
236 | test_print_accept "pt 10e20" "real*8" | |
237 | ||
238 | if $passcount then { | |
239 | pass "$passcount correct float literal comparisons" | |
240 | } | |
241 | } | |
242 | ||
243 | # Start with a fresh gdb. | |
244 | ||
245 | gdb_exit | |
246 | gdb_start | |
247 | gdb_reinitialize_dir $srcdir/$subdir | |
248 | ||
249 | send "set print sevenbit-strings\n" ; expect -re ".*$prompt $" | |
250 | ||
251 | if [set_lang_fortran] then { | |
252 | test_integer_literal_types_accepted | |
253 | test_integer_literal_types_rejected | |
254 | test_logical_literal_types_accepted | |
255 | test_character_literal_types_accepted | |
256 | test_float_literal_types_accepted | |
257 | } else { | |
258 | warning "$test_name tests suppressed." | |
259 | } |