Commit | Line | Data |
---|---|---|
c906108c SS |
1 | # Copyright (C) 1992, 1995, 1997 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 | |
7a292a7a | 15 | # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
c906108c SS |
16 | |
17 | # Please email any bugs, comments, and/or additions to this file to: | |
18 | # bug-gdb@prep.ai.mit.edu | |
19 | ||
20 | if $tracelevel then { | |
21 | strace $tracelevel | |
22 | } | |
23 | ||
24 | if [skip_chill_tests] then { continue } | |
25 | ||
26 | set prms_id 0 | |
27 | set bug_id 0 | |
28 | ||
29 | # Set the current language to chill. This counts as a test. If it | |
30 | # fails, then we skip the other tests. | |
31 | ||
32 | set testfile "tests2" | |
33 | set srcfile ${srcdir}/$subdir/${testfile}.ch | |
34 | set binfile ${objdir}/${subdir}/${testfile}.exe | |
35 | if { [compile "${srcfile} -g -w -o ${binfile} ${CHILL_RT0} ${CHILL_LIB}"] != "" } { | |
36 | perror "Couldn't compile ${srcfile}" | |
37 | return -1 | |
38 | } | |
39 | ||
40 | global infinity | |
41 | if [istarget "i*86-*-sysv4*"] then { | |
42 | set infinity "inf" | |
43 | } else { | |
44 | set infinity "Infinity" | |
45 | } | |
46 | ||
47 | proc set_lang_chill {} { | |
48 | global gdb_prompt | |
49 | global binfile objdir subdir | |
50 | ||
51 | if ![file exists $objdir/$subdir/$binfile] then { | |
52 | return 0 | |
53 | } | |
54 | verbose "loading file '$objdir/$subdir/$binfile'" | |
55 | gdb_load $objdir/$subdir/$binfile | |
56 | ||
57 | send_gdb "set language chill\n" | |
58 | gdb_expect { | |
59 | -re ".*$gdb_prompt $" {} | |
60 | timeout { fail "set language chill (timeout)" ; return 0 } | |
61 | } | |
62 | ||
63 | send_gdb "show language\n" | |
64 | gdb_expect { | |
65 | -re ".* source language is \"chill\".*$gdb_prompt $" { | |
66 | pass "set language to \"chill\"" | |
67 | send_gdb "break dummyfunc\n" | |
68 | gdb_expect { | |
69 | -re ".*$gdb_prompt $" { | |
70 | send_gdb "run\n" | |
71 | gdb_expect -re ".*$gdb_prompt $" {} | |
72 | return 1 | |
73 | } | |
74 | timeout { | |
75 | fail "can't set breakpoint (timeout)" | |
76 | return 0 | |
77 | } | |
78 | } | |
79 | } | |
80 | -re ".*$gdb_prompt $" { | |
81 | fail "setting language to \"chill\"" | |
82 | return 0 | |
83 | } | |
84 | timeout { | |
85 | fail "can't show language (timeout)" | |
86 | return 0 | |
87 | } | |
88 | } | |
89 | } | |
90 | ||
91 | # checks if structure was accessed correctly | |
92 | proc test_write { args } { | |
93 | global gdb_prompt | |
94 | ||
95 | if [llength $args]==5 then { | |
96 | set message [lindex $args 4] | |
97 | set extended [lindex $args 3] | |
98 | set matchval [lindex $args 2] | |
99 | } elseif [llength $args]==4 then { | |
100 | set message [lindex $args 3] | |
101 | set matchval [lindex $args 2] | |
102 | set extended "" | |
103 | } elseif [llength $args]==3 then { | |
104 | set message [lindex $args 2] | |
105 | set extended "" | |
106 | } else { | |
107 | warning "test ($args) write called with wrong number of arguments" | |
108 | return | |
109 | } | |
110 | ||
111 | set location [lindex $args 0] | |
112 | set value [lindex $args 1] | |
113 | if ![info exists matchval] then { | |
114 | set matchval $value | |
115 | } | |
116 | verbose "loc: $location, val: $value, msg: $message, ext: $extended, match: $matchval" | |
117 | ||
118 | verbose "setting var $value..." | |
119 | send_gdb "set var $location.m$extended := $value\n" | |
120 | gdb_expect -re ".*$gdb_prompt $" {} | |
121 | gdb_test "print $location" \ | |
122 | ".*= \[\[\]\\.p1: 2863311530, \\.m: $matchval, \\.p2: 1431655765\[\]\]"\ | |
123 | "$message" | |
124 | } | |
125 | ||
126 | # test write access from gdb (setvar x:=y) from gdb | |
127 | proc write_access { } { | |
128 | global infinity | |
129 | ||
130 | verbose "testing write access to locations" | |
131 | ||
132 | # discrete modes | |
133 | test_write b1 127 "byte write 1" | |
134 | test_write b1 -128 "byte write 2" | |
135 | test_write b1 0 "byte write 3" | |
136 | test_write ub1 255 "ubyte write 1" | |
137 | test_write ub1 0 "ubyte write 2" | |
138 | test_write ub1 42 "ubyte write 3" | |
139 | test_write i1 32767 "int write 1" | |
140 | test_write i1 -32768 "int write 2" | |
141 | test_write i1 0 "int write 3" | |
142 | test_write ui1 65535 "uint write 1" | |
143 | test_write ui1 0 "uint write 2" | |
144 | test_write ui1 123 "uint write 3" | |
145 | test_write l1 2147483647 "long write 1" | |
146 | test_write l1 -2147483648 "long write 2" | |
147 | test_write l1 0 "long write 3" | |
148 | test_write ul1 4294967295 "ulong write 1" | |
149 | test_write ul1 0 "ulong write 2" | |
150 | test_write ul1 1000000 "ulong write 3" | |
151 | test_write bo1 FALSE "bool write 1" | |
152 | test_write bo1 TRUE "bool write 2" | |
153 | test_write c1 \"1234\" "char write 1" | |
154 | test_write c2 \"1234567\" "char write 2" | |
155 | test_write c3 \"654321\" "char write 3" | |
156 | test_write c4 C'65' 'e' "char write 4" | |
157 | test_write bi1 B'10100101' "bitstring write 1" | |
158 | test_write bi2 B'0101001010' "bitstring write 2" | |
159 | test_write se1 a "set write 1" | |
160 | test_write se1 h "set write 2" | |
161 | # The following two use numbered sets with too-large values. | |
162 | setup_xfail "*-*-*" | |
163 | test_write nse1 nb "numbered set write 1" | |
164 | setup_xfail "*-*-*" | |
165 | test_write nse1 nc "numbered set write 2" | |
166 | test_write r1 127 "range write 1" | |
167 | test_write r2 32767 "range write 2" | |
168 | test_write r3 2147483647 "range write 3" | |
169 | ||
170 | # powerset modes | |
171 | test_write p1 {[pa:ph]} {\[pa:ph\]} "powerset write 1" | |
172 | test_write p1 {[pa, pc:pf, ph]} {\[pa, pc:pf, ph\]} "powerset write 2" | |
173 | test_write p1 {[pa, pc, pe, pg]} {\[pa, pc, pe, pg\]} "powerset write 3" | |
174 | test_write p1 {[]} {\[\]} "powerset write 4" | |
175 | test_write p2 {[1:32]} {\[1:32\]} "powerset write 5" | |
176 | test_write p2 {[1, 3:30, 32]} {\[1, 3:30, 32\]} "powerset write 6" | |
177 | test_write p2 {[1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31]} {\[1, 3, 5, 7, 9, 11, 13, 15, 17, 19, 21, 23, 25, 27, 29, 31\]} \ | |
178 | "powerset write 7" | |
179 | test_write p2 {[]} {\[\]} "powerset write 8" | |
180 | ||
181 | # Fixme: this should be rejected by gnuchill | |
182 | # test_write p3 {[-2147483648:2147483647]} {\[-2147483648:2147483647\]} \ | |
183 | # "powerset write 9" | |
184 | # test_write p3 {[-2147483648, -1000000:1000000, 2147483647]} \ | |
185 | # {\[-2147483648, -1000000:1000000, 2147483647\]} \ | |
186 | # "powerset write 10" | |
187 | # test_write p3 {[-99, -97, -95, 1001, 1003, 1005]} \ | |
188 | # {\[-99, -97, -95, 1001, 1003, 1005\]} "powerset write 11" | |
189 | # test_write p3 {[]} {\[\]} "powerset write 12" | |
190 | ||
191 | # reference modes | |
192 | test_write ref1 ->ref1 {H'[0-9a-fA-F]+} "reference write 1" | |
193 | test_write ref2 ->b1 {H'[0-9a-fA-F]+} "reference write 2" | |
194 | test_write ref1 NULL "reference write 3" | |
195 | test_write ref2 NULL "reference write 4" | |
196 | ||
197 | # procedure modes | |
198 | test_write pr1 NULL "procefure write 1" | |
199 | # FIXME: remove when NULL is understood | |
200 | test_write pr1 0 NULL "procefure write 2" | |
201 | test_write pr1 dummyfunc {H'[0-9a-fA-F]+ <dummyfunc>} "procedure write 3" | |
202 | ||
203 | # timing modes, FIXME when callbacks to timefunctions are implemented | |
204 | #test_write ti1 abstime(1970, 3, 12, 10, 43, 0) {} "time write 1" | |
205 | #test_write ti2 <set somehow a duration> | |
206 | xfail "timing modes not implemented yet" | |
207 | ||
208 | # real modes | |
209 | # This ones | |
210 | test_write re1 42.03 {42.0[0-9]*} "real write 1" | |
211 | test_write re1 0 "real write 2" | |
212 | test_write re1 "1e+38" {1e\+38|1\.0[0-9]*e\+38|9\.9[0-9]*e\+37} \ | |
213 | "real write 3" | |
214 | setup_xfail "i*86-pc-linux-gnu" "m68*-*-hpux*" | |
215 | test_write re1 "1e+39" $infinity "real write 4" | |
216 | test_write re2 42.03 {42.0[0-9]*} "real write 5" | |
217 | test_write re2 0 "real write 6" | |
218 | test_write re2 "1e+308" {1e\+308} "real write 7" | |
219 | setup_xfail "i*86-pc-linux-gnu" "m68*-*-hpux*" | |
220 | test_write re2 "1e+309" $infinity "real write 8" | |
221 | # array modes | |
222 | test_write arrl1 {[(1:3): [(1:2): -128]]} {\[\(1:3\): \[\(1:2\): -128\]\]}\ | |
223 | "array write 1" | |
224 | test_write arrl1 {[(1:3): [(1:2): 0]]} {\[\(1:3\): \[\(1:2\): 0\]\]}\ | |
225 | "array write 2" | |
226 | test_write arrl1 {[(1): [(1:2): 127], (2): [(1:2): -128], (3): [(1:2): 127]]} {\[\(1\): \[\(1:2\): 127\], \(2\): \[\(1:2\): -128\], \(3\): \[\(1:2\): 127\]\]}\ | |
227 | "array write 3" | |
228 | test_write arrl1 {[(1:3): [(1:2): 0]]} {\[\(1:3\): \[\(1:2\): 0\]\]}\ | |
229 | "array write 4" | |
230 | setup_xfail "*-*-*" | |
231 | # Bogus test case - type mismatch? | |
232 | test_write arrl1 {[(1): 127, (2): -128]} "array write 5" | |
233 | test_write arrl1 {[(1:3): [(1:2): 0]]} {\[\(1:3\): \[\(1:2\): 0\]\]}\ | |
234 | "array write 6" | |
235 | ||
236 | # structure modes | |
237 | test_write strul1 {[.a: -32768, .b: 32767, .ch: "ZZZZ"]} \ | |
238 | {\[\.a: -32768, \.b: 32767, \.ch: \"ZZZZ\"\]} \ | |
239 | "structure write 1" | |
240 | test_write strul1 {[.a: 0, .b: 0, .ch: "0000"]} \ | |
241 | {\[\.a: 0, \.b: 0, \.ch: \"0000\"\]} \ | |
242 | "structure write 2" | |
243 | test_write strul1 -32768 {\[\.a: -32768, \.b: 0, \.ch: \"0000\"\]} \ | |
244 | {.a} "structure write 3" | |
245 | test_write strul1 {[.a: 0, .b: 0, .ch: "0000"]} \ | |
246 | {\[\.a: 0, \.b: 0, \.ch: \"0000\"\]} \ | |
247 | "structure write 4" | |
248 | test_write strul1 -32768 {\[\.a: 0, \.b: -32768, \.ch: \"0000\"\]} \ | |
249 | {.b} "structure write 5" | |
250 | test_write strul1 {[.a: 0, .b: 0, .ch: "0000"]} \ | |
251 | {\[\.a: 0, \.b: 0, \.ch: \"0000\"\]} \ | |
252 | "structure write 6" | |
253 | test_write strul1 \"HUGO\" {\[\.a: 0, \.b: 0, \.ch: \"HUGO\"\]} \ | |
254 | {.ch} "structure write 7" | |
255 | } | |
256 | ||
257 | # Start with a fresh gdb. | |
258 | ||
259 | set binfile "tests2.exe" | |
260 | ||
261 | gdb_exit | |
262 | gdb_start | |
263 | gdb_reinitialize_dir $srcdir/$subdir | |
264 | ||
265 | gdb_test "set print sevenbit-strings" ".*" | |
266 | ||
267 | if [set_lang_chill] then { | |
268 | write_access | |
269 | } else { | |
270 | warning "$test_name tests suppressed." | |
271 | } |