1 # Copyright (C) 2009-2016 Free Software Foundation, Inc.
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.
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.
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/>.
16 # This file is part of the GDB testsuite.
17 # It tests the mechanism of exposing types to Guile.
19 load_lib gdb-guile.exp
23 if [get_compiler_info c++] {
27 # Build inferior to language specification.
29 proc build_inferior {exefile lang} {
30 global srcdir subdir srcfile
32 if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${exefile}" executable "debug $lang"] != "" } {
33 untested "Couldn't compile ${srcfile} in $lang mode"
40 # The result is the same as gdb_guile_runto_main.
42 proc restart_gdb {exefile} {
47 gdb_reinitialize_dir $srcdir/$subdir
50 if { [skip_guile_tests] } {
54 if ![gdb_guile_runto_main] {
57 gdb_scm_test_silent_cmd "guile (use-modules (gdb iterator))" \
58 "load iterator module"
63 # Set breakpoint and run to that breakpoint.
66 gdb_breakpoint [gdb_get_line_number $bp]
67 gdb_continue_to_breakpoint $bp
70 proc test_fields {lang} {
71 with_test_prefix "test_fields" {
74 # fields of a typedef should still return the underlying field list
75 gdb_test "guile (print (length (type-fields (value-type (parse-and-eval \"ts\")))))" \
76 "= 2" "$lang typedef field list"
79 # Test usage with a class.
80 gdb_scm_test_silent_cmd "print c" "print value (c)"
81 gdb_scm_test_silent_cmd "guile (define c (history-ref 0))" \
82 "get value (c) from history"
83 gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type c)))" \
84 "get fields from c type"
85 gdb_test "guile (print (length fields))" \
86 "= 2" "check number of fields of c"
87 gdb_test "guile (print (field-name (car fields)))" \
88 "= c" "check class field c name"
89 gdb_test "guile (print (field-name (cadr fields)))" \
90 "= d" "check class field d name"
93 # Test normal fields usage in structs.
94 gdb_scm_test_silent_cmd "print st" "print value (st)"
95 gdb_scm_test_silent_cmd "guile (define st (history-ref 0))" \
96 "get value (st) from history"
97 gdb_scm_test_silent_cmd "guile (define st-type (value-type st))" \
99 gdb_scm_test_silent_cmd "guile (define fields (type-fields st-type))" \
100 "get fields from st.type"
101 gdb_test "guile (print (length fields))" \
102 "= 2" "check number of fields (st)"
103 gdb_test "guile (print (field-name (car fields)))" \
104 "= a" "check structure field a name"
105 gdb_test "guile (print (field-name (cadr fields)))" \
106 "= b" "check structure field b name"
107 gdb_test "guile (print (field-name (type-field st-type \"a\")))" \
108 "= a" "check fields lookup by name"
111 gdb_test "guile (print (type-has-field? st-type \"b\"))" \
112 "= #t" "check existent field"
113 gdb_test "guile (print (type-has-field? st-type \"nosuch\"))" \
114 "= #f" "check non-existent field"
116 # Test Guile mapping behavior of gdb:type for structs/classes.
117 gdb_test "guile (print (type-num-fields (value-type st)))" \
118 "= 2" "check number of fields (st) with type-num-fields"
119 gdb_scm_test_silent_cmd "guile (define fi (make-field-iterator st-type))" \
120 "create field iterator"
121 gdb_test "guile (print (iterator-map field-bitpos fi))" \
122 "= \\(0 32\\)" "check field iterator"
124 # Test rejection of mapping operations on scalar types.
125 gdb_test "guile (print (make-field-iterator (field-type (type-field st-type \"a\"))))" \
126 "ERROR: .*: Out of range: type is not a structure, union, or enum type in position 1: .*" \
127 "check field iterator on bad type"
130 gdb_scm_test_silent_cmd "print ar" "print value (ar)"
131 gdb_scm_test_silent_cmd "guile (define ar (history-ref 0))" \
132 "get value (ar) from history"
133 gdb_scm_test_silent_cmd "guile (define ar0 (value-subscript ar 0))" \
135 gdb_test "guile (print (value-cast ar0 (type-array (value-type ar0) 1)))" \
136 "= \\{1, 2\\}" "cast to array with one argument"
137 gdb_test "guile (print (value-cast ar0 (type-array (value-type ar0) 0 1)))" \
138 "= \\{1, 2\\}" "cast to array with two arguments"
141 # Note: vectors cast differently than arrays. Here ar[0] is replicated
142 # for the size of the vector.
143 gdb_scm_test_silent_cmd "print vec_data_1" "print value (vec_data_1)"
144 gdb_scm_test_silent_cmd "guile (define vec_data_1 (history-ref 0))" \
145 "get value (vec_data_1) from history"
147 gdb_scm_test_silent_cmd "print vec_data_2" "print value (vec_data_2)"
148 gdb_scm_test_silent_cmd "guile (define vec_data_2 (history-ref 0))" \
149 "get value (vec_data_2) from history"
151 gdb_scm_test_silent_cmd "guile (define vec1 (value-cast vec_data_1 (type-vector (value-type ar0) 1)))" \
153 gdb_test "guile (print vec1)" \
154 "= \\{1, 1\\}" "cast to vector with one argument"
155 gdb_scm_test_silent_cmd "guile (define vec2 (value-cast vec_data_1 (type-vector (value-type ar0) 0 1)))" \
157 gdb_test "guile (print vec2)" \
158 "= \\{1, 1\\}" "cast to vector with two arguments"
159 gdb_test "guile (print (value=? vec1 vec2))" \
161 gdb_scm_test_silent_cmd "guile (define vec3 (value-cast vec_data_2 (type-vector (value-type ar0) 1)))" \
163 gdb_test "guile (print (value=? vec1 vec3))" \
168 proc test_equality {lang} {
169 with_test_prefix "test_equality" {
170 gdb_scm_test_silent_cmd "guile (define st (parse-and-eval \"st\"))" \
172 gdb_scm_test_silent_cmd "guile (define ar (parse-and-eval \"ar\"))" \
174 gdb_test "guile (print (eq? (value-type st) (value-type st)))" \
175 "= #t" "test type eq? on equal types"
176 gdb_test "guile (print (eq? (value-type st) (value-type ar)))" \
177 "= #f" "test type eq? on not-equal types"
178 gdb_test "guile (print (equal? (value-type st) (value-type st)))" \
179 "= #t" "test type eq? on equal types"
180 gdb_test "guile (print (equal? (value-type st) (value-type ar)))" \
181 "= #f" "test type eq? on not-equal types"
183 if {$lang == "c++"} {
184 gdb_scm_test_silent_cmd "guile (define c (parse-and-eval \"c\"))" \
186 gdb_scm_test_silent_cmd "guile (define d (parse-and-eval \"d\"))" \
188 gdb_test "guile (print (eq? (value-type c) (field-type (car (type-fields (value-type d))))))" \
189 "= #t" "test c++ type eq? on equal types"
190 gdb_test "guile (print (eq? (value-type c) (value-type d)))" \
191 "= #f" "test c++ type eq? on not-equal types"
192 gdb_test "guile (print (equal? (value-type c) (field-type (car (type-fields (value-type d))))))" \
193 "= #t" "test c++ type equal? on equal types"
194 gdb_test "guile (print (equal? (value-type c) (value-type d)))" \
195 "= #f" "test c++ type equal? on not-equal types"
201 with_test_prefix "test_enum" {
202 gdb_scm_test_silent_cmd "print e" "print value (e)"
203 gdb_scm_test_silent_cmd "guile (define e (history-ref 0))" \
204 "get value (e) from history"
205 gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type e)))" \
206 "extract type fields from e"
207 gdb_test "guile (print (length fields))" \
208 "= 3" "check the number of enum fields"
209 gdb_test "guile (print (field-name (car fields)))" \
210 "= v1" "check enum field\[0\] name"
211 gdb_test "guile (print (field-name (cadr fields)))" \
212 "= v2" "check enum field\[1\]name"
214 # Ditto but by mapping operations.
215 gdb_test "guile (print (type-num-fields (value-type e)))" \
216 "= 3" "check the number of enum values"
217 gdb_test "guile (print (field-name (type-field (value-type e) \"v1\")))" \
218 "= v1" "check enum field lookup by name (v1)"
219 gdb_test "guile (print (field-name (type-field (value-type e) \"v3\")))" \
220 "= v3" "check enum field lookup by name (v3)"
221 gdb_test "guile (print (iterator-map field-enumval (make-field-iterator (value-type e))))" \
222 "\\(0 1 2\\)" "check enum fields iteration"
226 proc test_base_class {} {
227 with_test_prefix "test_base_class" {
228 gdb_scm_test_silent_cmd "print d" "print value (d)"
229 gdb_scm_test_silent_cmd "guile (define d (history-ref 0))" \
230 "get value (d) from history"
231 gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type d)))" \
232 "extract type fields from d"
233 gdb_test "guile (print (length fields))" \
234 "= 3" "check the number of fields"
235 gdb_test "guile (print (field-baseclass? (car fields)))" \
236 "= #t" "check base class (fields\[0\])"
237 gdb_test "guile (print (field-baseclass? (cadr fields)))" \
238 "= #f" "check base class (fields\[1\])"
243 with_test_prefix "test_range" {
244 with_test_prefix "on ranged value" {
245 # Test a valid range request.
246 gdb_scm_test_silent_cmd "print ar" "print value (ar)"
247 gdb_scm_test_silent_cmd "guile (define ar (history-ref 0))" \
248 "get value (ar) from history"
249 gdb_test "guile (print (length (type-range (value-type ar))))" \
250 "= 2" "check correct tuple length"
251 gdb_test "guile (print (type-range (value-type ar)))" \
252 "= \\(0 1\\)" "check range"
255 with_test_prefix "on unranged value" {
256 # Test where a range does not exist.
257 gdb_scm_test_silent_cmd "print st" "print value (st)"
258 gdb_scm_test_silent_cmd "guile (define st (history-ref 0))" \
259 "get value (st) from history"
260 gdb_test "guile (print (type-range (value-type st)))" \
261 "ERROR: .*: Wrong type argument in position 1 \\(expecting ranged type\\): .*" \
262 "check range for non ranged type"
269 if { [build_inferior "${binfile}" "c"] < 0 } {
272 if ![restart_gdb "${binfile}"] {
276 with_test_prefix "lang_c" {
277 runto_bp "break to inspect struct and array."
285 if { [build_inferior "${binfile}-cxx" "c++"] < 0 } {
288 if ![restart_gdb "${binfile}-cxx"] {
292 with_test_prefix "lang_cpp" {
293 runto_bp "break to inspect struct and array."