1# Copyright (C) 2009-2020 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 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# This file is part of the GDB testsuite.
17# It tests the mechanism of exposing types to Guile.
18
19load_lib gdb-guile.exp
20
21standard_testfile
22
23if [get_compiler_info c++] {
24    return -1
25}
26
27# Build inferior to language specification.
28
29proc build_inferior {exefile lang} {
30    global srcdir subdir srcfile
31
32    if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${exefile}" executable "debug $lang"] != "" } {
33	untested "failed to compile in $lang mode"
34	return -1
35    }
36    return 0
37}
38
39# Restart GDB.
40# The result is the same as gdb_guile_runto_main.
41
42proc restart_gdb {exefile} {
43    global srcdir subdir
44
45    gdb_exit
46    gdb_start
47    gdb_reinitialize_dir $srcdir/$subdir
48    gdb_load ${exefile}
49
50    if { [skip_guile_tests] } {
51	return 0
52    }
53
54    if ![gdb_guile_runto_main] {
55	return 0
56    }
57    gdb_scm_test_silent_cmd "guile (use-modules (gdb iterator))" \
58	"load iterator module"
59
60    return 1
61}
62
63# Set breakpoint and run to that breakpoint.
64
65proc runto_bp {bp} {
66    gdb_breakpoint [gdb_get_line_number $bp]
67    gdb_continue_to_breakpoint $bp
68}
69
70proc test_fields {lang} {
71    with_test_prefix "test_fields" {
72	global gdb_prompt
73
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"
77
78	if {$lang == "c++"} {
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"
91	}
92
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))" \
98	    "get st-type"
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"
109
110	# Test has-field?
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"
115
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"
123
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"
128
129	# Test type-array.
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))" \
134	    "define ar0"
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"
139
140	# Test type-vector.
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"
146
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"
150
151	gdb_scm_test_silent_cmd "guile (define vec1 (value-cast vec_data_1 (type-vector (value-type ar0) 1)))" \
152	    "set vec1"
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)))" \
156	    "set vec2"
157	gdb_test "guile (print vec2)" \
158	    "= \\{1, 1\\}" "cast to vector with two arguments"
159	gdb_test "guile (print (value=? vec1 vec2))" \
160	    "= #t"
161	gdb_scm_test_silent_cmd "guile (define vec3 (value-cast vec_data_2 (type-vector (value-type ar0) 1)))" \
162	    "set vec3"
163	gdb_test "guile (print (value=? vec1 vec3))" \
164	    "= #f"
165    }
166}
167
168proc test_equality {lang} {
169    with_test_prefix "test_equality" {
170	gdb_scm_test_silent_cmd "guile (define st (parse-and-eval \"st\"))" \
171	    "get st"
172	gdb_scm_test_silent_cmd "guile (define ar (parse-and-eval \"ar\"))" \
173	    "get 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"
182
183	if {$lang == "c++"} {
184	    gdb_scm_test_silent_cmd "guile (define c (parse-and-eval \"c\"))" \
185		"get c"
186	    gdb_scm_test_silent_cmd "guile (define d (parse-and-eval \"d\"))" \
187		"get 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"
196	}
197    }
198}
199
200proc test_enums {} {
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"
213
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"
223    }
224}
225
226proc 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\])"
239    }
240}
241
242proc test_range {} {
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"
253	}
254
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"
263	}
264    }
265}
266
267# Perform C Tests.
268
269if { [build_inferior "${binfile}" "c"] < 0 } {
270    return
271}
272if ![restart_gdb "${binfile}"] {
273    return
274}
275
276with_test_prefix "lang_c" {
277    runto_bp "break to inspect struct and array."
278    test_fields "c"
279    test_equality "c"
280    test_enums
281}
282
283# Perform C++ Tests.
284
285if { [build_inferior "${binfile}-cxx" "c++"] < 0 } {
286    return
287}
288if ![restart_gdb "${binfile}-cxx"] {
289    return
290}
291
292with_test_prefix "lang_cpp" {
293    runto_bp "break to inspect struct and array."
294    test_fields "c++"
295    test_base_class
296    test_range
297    test_equality "c++"
298    test_enums
299}
300