1 # Copyright (C) 2009-2022 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 # Build inferior to language specification.
25 proc build_inferior {exefile lang} {
26 global srcdir subdir srcfile
28 if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${exefile}" executable "debug $lang"] != "" } {
29 untested "failed to compile in $lang mode"
36 # The result is the same as gdb_guile_runto_main.
38 proc restart_gdb {exefile} {
43 gdb_reinitialize_dir $srcdir/$subdir
46 if { [skip_guile_tests] } {
50 if ![gdb_guile_runto_main] {
53 gdb_scm_test_silent_cmd "guile (use-modules (gdb iterator))" \
54 "load iterator module" 0
59 # Set breakpoint and run to that breakpoint.
62 gdb_breakpoint [gdb_get_line_number $bp]
63 gdb_continue_to_breakpoint $bp
66 proc test_fields {lang} {
67 with_test_prefix "test_fields" {
70 # fields of a typedef should still return the underlying field list
71 gdb_test "guile (print (length (type-fields (value-type (parse-and-eval \"ts\")))))" \
72 "= 2" "$lang typedef field list"
75 # Test usage with a class.
76 gdb_scm_test_silent_cmd "print c" "print value (c)"
77 gdb_scm_test_silent_cmd "guile (define c (history-ref 0))" \
78 "get value (c) from history"
79 gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type c)))" \
80 "get fields from c type"
81 gdb_test "guile (print (length fields))" \
82 "= 2" "check number of fields of c"
83 gdb_test "guile (print (field-name (car fields)))" \
84 "= c" "check class field c name"
85 gdb_test "guile (print (field-name (cadr fields)))" \
86 "= d" "check class field d name"
89 # Test normal fields usage in structs.
90 gdb_scm_test_silent_cmd "print st" "print value (st)"
91 gdb_scm_test_silent_cmd "guile (define st (history-ref 0))" \
92 "get value (st) from history"
93 gdb_scm_test_silent_cmd "guile (define st-type (value-type st))" \
95 gdb_scm_test_silent_cmd "guile (define fields (type-fields st-type))" \
96 "get fields from st.type"
97 gdb_test "guile (print (length fields))" \
98 "= 2" "check number of fields (st)"
99 gdb_test "guile (print (field-name (car fields)))" \
100 "= a" "check structure field a name"
101 gdb_test "guile (print (field-name (cadr fields)))" \
102 "= b" "check structure field b name"
103 gdb_test "guile (print (field-name (type-field st-type \"a\")))" \
104 "= a" "check fields lookup by name"
107 gdb_test "guile (print (type-has-field? st-type \"b\"))" \
108 "= #t" "check existent field"
109 gdb_test "guile (print (type-has-field? st-type \"nosuch\"))" \
110 "= #f" "check non-existent field"
112 # Test Guile mapping behavior of gdb:type for structs/classes.
113 gdb_test "guile (print (type-num-fields (value-type st)))" \
114 "= 2" "check number of fields (st) with type-num-fields"
115 gdb_scm_test_silent_cmd "guile (define fi (make-field-iterator st-type))" \
116 "create field iterator"
117 gdb_test "guile (print (iterator-map field-bitpos fi))" \
118 "= \\(0 32\\)" "check field iterator"
120 # Test rejection of mapping operations on scalar types.
121 gdb_test "guile (print (make-field-iterator (field-type (type-field st-type \"a\"))))" \
122 "ERROR: .*: Out of range: type is not a structure, union, or enum type in position 1: .*" \
123 "check field iterator on bad type"
126 gdb_scm_test_silent_cmd "print ar" "print value (ar)"
127 gdb_scm_test_silent_cmd "guile (define ar (history-ref 0))" \
128 "get value (ar) from history"
129 gdb_scm_test_silent_cmd "guile (define ar0 (value-subscript ar 0))" \
131 gdb_test "guile (print (value-cast ar0 (type-array (value-type ar0) 1)))" \
132 "= \\{1, 2\\}" "cast to array with one argument"
133 gdb_test "guile (print (value-cast ar0 (type-array (value-type ar0) 0 1)))" \
134 "= \\{1, 2\\}" "cast to array with two arguments"
137 # Note: vectors cast differently than arrays. Here ar[0] is replicated
138 # for the size of the vector.
139 gdb_scm_test_silent_cmd "print vec_data_1" "print value (vec_data_1)"
140 gdb_scm_test_silent_cmd "guile (define vec_data_1 (history-ref 0))" \
141 "get value (vec_data_1) from history"
143 gdb_scm_test_silent_cmd "print vec_data_2" "print value (vec_data_2)"
144 gdb_scm_test_silent_cmd "guile (define vec_data_2 (history-ref 0))" \
145 "get value (vec_data_2) from history"
147 gdb_scm_test_silent_cmd "guile (define vec1 (value-cast vec_data_1 (type-vector (value-type ar0) 1)))" \
149 gdb_test "guile (print vec1)" \
150 "= \\{1, 1\\}" "cast to vector with one argument"
151 gdb_scm_test_silent_cmd "guile (define vec2 (value-cast vec_data_1 (type-vector (value-type ar0) 0 1)))" \
153 gdb_test "guile (print vec2)" \
154 "= \\{1, 1\\}" "cast to vector with two arguments"
155 gdb_test "guile (print (value=? vec1 vec2))" \
157 gdb_scm_test_silent_cmd "guile (define vec3 (value-cast vec_data_2 (type-vector (value-type ar0) 1)))" \
159 gdb_test "guile (print (value=? vec1 vec3))" \
164 proc test_equality {lang} {
165 with_test_prefix "test_equality" {
166 gdb_scm_test_silent_cmd "guile (define st (parse-and-eval \"st\"))" \
168 gdb_scm_test_silent_cmd "guile (define ar (parse-and-eval \"ar\"))" \
170 gdb_test "guile (print (eq? (value-type st) (value-type st)))" \
171 "= #t" "test type eq? on equal types"
172 gdb_test "guile (print (eq? (value-type st) (value-type ar)))" \
173 "= #f" "test type eq? on not-equal types"
174 gdb_test "guile (print (equal? (value-type st) (value-type st)))" \
175 "= #t" "test type equal? on equal types"
176 gdb_test "guile (print (equal? (value-type st) (value-type ar)))" \
177 "= #f" "test type equal? on not-equal types"
179 if {$lang == "c++"} {
180 gdb_scm_test_silent_cmd "guile (define c (parse-and-eval \"c\"))" \
182 gdb_scm_test_silent_cmd "guile (define d (parse-and-eval \"d\"))" \
184 gdb_test "guile (print (eq? (value-type c) (field-type (car (type-fields (value-type d))))))" \
185 "= #t" "test c++ type eq? on equal types"
186 gdb_test "guile (print (eq? (value-type c) (value-type d)))" \
187 "= #f" "test c++ type eq? on not-equal types"
188 gdb_test "guile (print (equal? (value-type c) (field-type (car (type-fields (value-type d))))))" \
189 "= #t" "test c++ type equal? on equal types"
190 gdb_test "guile (print (equal? (value-type c) (value-type d)))" \
191 "= #f" "test c++ type equal? on not-equal types"
197 with_test_prefix "test_enum" {
198 gdb_scm_test_silent_cmd "print e" "print value (e)"
199 gdb_scm_test_silent_cmd "guile (define e (history-ref 0))" \
200 "get value (e) from history"
201 gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type e)))" \
202 "extract type fields from e"
203 gdb_test "guile (print (length fields))" \
204 "= 3" "check the number of enum fields"
205 gdb_test "guile (print (field-name (car fields)))" \
206 "= v1" "check enum field\[0\] name"
207 gdb_test "guile (print (field-name (cadr fields)))" \
208 "= v2" "check enum field\[1\]name"
210 # Ditto but by mapping operations.
211 gdb_test "guile (print (type-num-fields (value-type e)))" \
212 "= 3" "check the number of enum values"
213 gdb_test "guile (print (field-name (type-field (value-type e) \"v1\")))" \
214 "= v1" "check enum field lookup by name (v1)"
215 gdb_test "guile (print (field-name (type-field (value-type e) \"v3\")))" \
216 "= v3" "check enum field lookup by name (v3)"
217 gdb_test "guile (print (iterator-map field-enumval (make-field-iterator (value-type e))))" \
218 "\\(0 1 2\\)" "check enum fields iteration"
222 proc test_base_class {} {
223 with_test_prefix "test_base_class" {
224 gdb_scm_test_silent_cmd "print d" "print value (d)"
225 gdb_scm_test_silent_cmd "guile (define d (history-ref 0))" \
226 "get value (d) from history"
227 gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type d)))" \
228 "extract type fields from d"
229 gdb_test "guile (print (length fields))" \
230 "= 3" "check the number of fields"
231 gdb_test "guile (print (field-baseclass? (car fields)))" \
232 "= #t" "check base class (fields\[0\])"
233 gdb_test "guile (print (field-baseclass? (cadr fields)))" \
234 "= #f" "check base class (fields\[1\])"
239 with_test_prefix "test_range" {
240 with_test_prefix "on ranged value" {
241 # Test a valid range request.
242 gdb_scm_test_silent_cmd "print ar" "print value (ar)"
243 gdb_scm_test_silent_cmd "guile (define ar (history-ref 0))" \
244 "get value (ar) from history"
245 gdb_test "guile (print (length (type-range (value-type ar))))" \
246 "= 2" "check correct tuple length"
247 gdb_test "guile (print (type-range (value-type ar)))" \
248 "= \\(0 1\\)" "check range"
251 with_test_prefix "on unranged value" {
252 # Test where a range does not exist.
253 gdb_scm_test_silent_cmd "print st" "print value (st)"
254 gdb_scm_test_silent_cmd "guile (define st (history-ref 0))" \
255 "get value (st) from history"
256 gdb_test "guile (print (type-range (value-type st)))" \
257 "ERROR: .*: Wrong type argument in position 1 \\(expecting ranged type\\): .*" \
258 "check range for non ranged type"
261 with_test_prefix "on flexible array member" {
262 gdb_scm_test_silent_cmd "print f" "print value (f)"
263 gdb_scm_test_silent_cmd "guile (define f (history-ref 0))" \
264 "get value (f) from history"
265 gdb_test "guile (print (type-range (field-type (type-field (value-type (value-dereference f)) \"items\"))))" \
267 gdb_test "guile (print (value-subscript (value-field (value-dereference f) \"items\") 0))" \
269 gdb_test "guile (print (value-subscript (value-field (value-dereference f) \"items\") 1))" \
277 if { [build_inferior "${binfile}" "c"] < 0 } {
280 if ![restart_gdb "${binfile}"] {
284 with_test_prefix "lang_c" {
285 runto_bp "break to inspect struct and array."
293 if { [build_inferior "${binfile}-cxx" "c++"] < 0 } {
296 if ![restart_gdb "${binfile}-cxx"] {
300 with_test_prefix "lang_cpp" {
301 runto_bp "break to inspect struct and array."