gdb/testsuite/gdb.guile/scm-type.exp

   1 # Copyright (C) 2009-2023 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
  19 load_lib gdb-guile.exp
  20
  21 standard_testfile
  22
  23 # Build inferior to language specification.
  24
  25 proc build_inferior {exefile lang} {
  26     global srcdir subdir srcfile
  27
  28     if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${exefile}" executable "debug $lang"] != "" } {
  29         untested "failed to compile in $lang mode"
  30         return -1
  31     }
  32     return 0
  33 }
  34
  35 # Restart GDB.
  36 # The result is the same as gdb_guile_runto_main.
  37
  38 proc restart_gdb {exefile} {
  39     global srcdir subdir
  40
  41     gdb_exit
  42     gdb_start
  43     gdb_reinitialize_dir $srcdir/$subdir
  44     gdb_load ${exefile}
  45
  46     if { [skip_guile_tests] } {
  47         return 0
  48     }
  49
  50     if ![gdb_guile_runto_main] {
  51         return 0
  52     }
  53     gdb_scm_test_silent_cmd "guile (use-modules (gdb iterator))" \
  54         "load iterator module" 0
  55
  56     return 1
  57 }
  58
  59 # Set breakpoint and run to that breakpoint.
  60
  61 proc runto_bp {bp} {
  62     gdb_breakpoint [gdb_get_line_number $bp]
  63     gdb_continue_to_breakpoint $bp
  64 }
  65
  66 proc test_fields {lang} {
  67     with_test_prefix "test_fields" {
  68         global gdb_prompt
  69
  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"
  73
  74         if {$lang == "c++"} {
  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"
  87         }
  88
  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))" \
  94             "get st-type"
  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"
 105
 106         # Test has-field?
 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"
 111
 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"
 119
 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"
 124
 125         # Test type-array.
 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))" \
 130             "define ar0"
 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"
 135
 136         # Test type-vector.
 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"
 142
 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"
 146
 147         gdb_scm_test_silent_cmd "guile (define vec1 (value-cast vec_data_1 (type-vector (value-type ar0) 1)))" \
 148             "set vec1"
 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)))" \
 152             "set vec2"
 153         gdb_test "guile (print vec2)" \
 154             "= \\{1, 1\\}" "cast to vector with two arguments"
 155         gdb_test "guile (print (value=? vec1 vec2))" \
 156             "= #t"
 157         gdb_scm_test_silent_cmd "guile (define vec3 (value-cast vec_data_2 (type-vector (value-type ar0) 1)))" \
 158             "set vec3"
 159         gdb_test "guile (print (value=? vec1 vec3))" \
 160             "= #f"
 161     }
 162 }
 163
 164 proc test_equality {lang} {
 165     with_test_prefix "test_equality" {
 166         gdb_scm_test_silent_cmd "guile (define st (parse-and-eval \"st\"))" \
 167             "get st"
 168         gdb_scm_test_silent_cmd "guile (define ar (parse-and-eval \"ar\"))" \
 169             "get 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"
 178
 179         if {$lang == "c++"} {
 180             gdb_scm_test_silent_cmd "guile (define c (parse-and-eval \"c\"))" \
 181                 "get c"
 182             gdb_scm_test_silent_cmd "guile (define d (parse-and-eval \"d\"))" \
 183                 "get 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"
 192         }
 193     }
 194 }
 195
 196 proc test_enums {} {
 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"
 209
 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"
 219     }
 220 }
 221
 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\])"
 235     }
 236 }
 237
 238 proc test_range {} {
 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"
 249         }
 250
 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"
 259         }
 260
 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\"))))" \
 266                 "= \\(0 (0|-1)\\)"
 267             gdb_test "guile (print (value-subscript (value-field (value-dereference f) \"items\") 0))" \
 268                 "= 111"
 269             gdb_test "guile (print (value-subscript (value-field (value-dereference f) \"items\") 1))" \
 270                 "= 222"
 271         }
 272     }
 273 }
 274
 275 # Perform C Tests.
 276
 277 if { [build_inferior "${binfile}" "c"] < 0 } {
 278     return
 279 }
 280 if ![restart_gdb "${binfile}"] {
 281     return
 282 }
 283
 284 with_test_prefix "lang_c" {
 285     runto_bp "break to inspect struct and array."
 286     test_fields "c"
 287     test_equality "c"
 288     test_enums
 289 }
 290
 291 # Perform C++ Tests.
 292
 293 if { [build_inferior "${binfile}-cxx" "c++"] < 0 } {
 294     return
 295 }
 296 if ![restart_gdb "${binfile}-cxx"] {
 297     return
 298 }
 299
 300 with_test_prefix "lang_cpp" {
 301     runto_bp "break to inspect struct and array."
 302     test_fields "c++"
 303     test_base_class
 304     test_range
 305     test_equality "c++"
 306     test_enums
 307 }