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