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

   1 # Copyright (C) 2009-2024 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     clean_restart $exefile
  42
  43     if { ![allow_guile_tests] } {
  44         return 0
  45     }
  46
  47     if ![gdb_guile_runto_main] {
  48         return 0
  49     }
  50     gdb_scm_test_silent_cmd "guile (use-modules (gdb iterator))" \
  51         "load iterator module" 0
  52
  53     return 1
  54 }
  55
  56 # Set breakpoint and run to that breakpoint.
  57
  58 proc runto_bp {bp} {
  59     gdb_breakpoint [gdb_get_line_number $bp]
  60     gdb_continue_to_breakpoint $bp
  61 }
  62
  63 proc test_fields {lang} {
  64     with_test_prefix "test_fields" {
  65         global gdb_prompt
  66
  67         # fields of a typedef should still return the underlying field list
  68         gdb_test "guile (print (length (type-fields (value-type (parse-and-eval \"ts\")))))" \
  69             "= 2" "$lang typedef field list"
  70
  71         if {$lang == "c++"} {
  72             # Test usage with a class.
  73             gdb_scm_test_silent_cmd "print c" "print value, c"
  74             gdb_scm_test_silent_cmd "guile (define c (history-ref 0))" \
  75                 "get value (c) from history"
  76             gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type c)))" \
  77                 "get fields from c type"
  78             gdb_test "guile (print (length fields))" \
  79                 "= 2" "check number of fields of c"
  80             gdb_test "guile (print (field-name (car fields)))" \
  81                 "= c" "check class field c name"
  82             gdb_test "guile (print (field-name (cadr fields)))" \
  83                 "= d" "check class field d name"
  84         }
  85
  86         # Test normal fields usage in structs.
  87         gdb_scm_test_silent_cmd "print st" "print value, st"
  88         gdb_scm_test_silent_cmd "guile (define st (history-ref 0))" \
  89             "get value (st) from history"
  90         gdb_scm_test_silent_cmd "guile (define st-type (value-type st))" \
  91             "get st-type"
  92         gdb_scm_test_silent_cmd "guile (define fields (type-fields st-type))" \
  93             "get fields from st.type"
  94         gdb_test "guile (print (length fields))" \
  95             "= 2" "check number of fields (st)"
  96         gdb_test "guile (print (field-name (car fields)))" \
  97             "= a" "check structure field a name"
  98         gdb_test "guile (print (field-name (cadr fields)))" \
  99             "= b" "check structure field b name"
 100         gdb_test "guile (print (field-name (type-field st-type \"a\")))" \
 101             "= a" "check fields lookup by name"
 102
 103         # Test has-field?
 104         gdb_test "guile (print (type-has-field? st-type \"b\"))" \
 105             "= #t" "check existent field"
 106         gdb_test "guile (print (type-has-field? st-type \"nosuch\"))" \
 107             "= #f" "check non-existent field"
 108
 109         # Test Guile mapping behavior of gdb:type for structs/classes.
 110         gdb_test "guile (print (type-num-fields (value-type st)))" \
 111             "= 2" "check number of fields (st) with type-num-fields"
 112         gdb_scm_test_silent_cmd "guile (define fi (make-field-iterator st-type))" \
 113             "create field iterator"
 114         gdb_test "guile (print (iterator-map field-bitpos fi))" \
 115             "= \\(0 32\\)" "check field iterator"
 116
 117         # Test rejection of mapping operations on scalar types.
 118         gdb_test "guile (print (make-field-iterator (field-type (type-field st-type \"a\"))))" \
 119             "ERROR: .*: Out of range: type is not a structure, union, or enum type in position 1: .*" \
 120             "check field iterator on bad type"
 121
 122         # Test type-array.
 123         gdb_scm_test_silent_cmd "print ar" "print value, ar"
 124         gdb_scm_test_silent_cmd "guile (define ar (history-ref 0))" \
 125             "get value (ar) from history"
 126         gdb_scm_test_silent_cmd "guile (define ar0 (value-subscript ar 0))" \
 127             "define ar0"
 128         gdb_test "guile (print (value-cast ar0 (type-array (value-type ar0) 1)))" \
 129             "= \\{1, 2\\}" "cast to array with one argument"
 130         gdb_test "guile (print (value-cast ar0 (type-array (value-type ar0) 0 1)))" \
 131             "= \\{1, 2\\}" "cast to array with two arguments"
 132
 133         # Test type-vector.
 134         # Note: vectors cast differently than arrays.  Here ar[0] is replicated
 135         # for the size of the vector.
 136         gdb_scm_test_silent_cmd "print vec_data_1" "print value, vec_data_1"
 137         gdb_scm_test_silent_cmd "guile (define vec_data_1 (history-ref 0))" \
 138             "get value (vec_data_1) from history"
 139
 140         gdb_scm_test_silent_cmd "print vec_data_2" "print value, vec_data_2"
 141         gdb_scm_test_silent_cmd "guile (define vec_data_2 (history-ref 0))" \
 142             "get value (vec_data_2) from history"
 143
 144         gdb_scm_test_silent_cmd "guile (define vec1 (value-cast vec_data_1 (type-vector (value-type ar0) 1)))" \
 145             "set vec1"
 146         gdb_test "guile (print vec1)" \
 147             "= \\{1, 1\\}" "cast to vector with one argument"
 148         gdb_scm_test_silent_cmd "guile (define vec2 (value-cast vec_data_1 (type-vector (value-type ar0) 0 1)))" \
 149             "set vec2"
 150         gdb_test "guile (print vec2)" \
 151             "= \\{1, 1\\}" "cast to vector with two arguments"
 152         gdb_test "guile (print (value=? vec1 vec2))" \
 153             "= #t"
 154         gdb_scm_test_silent_cmd "guile (define vec3 (value-cast vec_data_2 (type-vector (value-type ar0) 1)))" \
 155             "set vec3"
 156         gdb_test "guile (print (value=? vec1 vec3))" \
 157             "= #f"
 158     }
 159 }
 160
 161 proc test_equality {lang} {
 162     with_test_prefix "test_equality" {
 163         gdb_scm_test_silent_cmd "guile (define st (parse-and-eval \"st\"))" \
 164             "get st"
 165         gdb_scm_test_silent_cmd "guile (define ar (parse-and-eval \"ar\"))" \
 166             "get ar"
 167         gdb_test "guile (print (eq? (value-type st) (value-type st)))" \
 168             "= #t" "test type eq? on equal types"
 169         gdb_test "guile (print (eq? (value-type st) (value-type ar)))" \
 170             "= #f" "test type eq? on not-equal types"
 171         gdb_test "guile (print (equal? (value-type st) (value-type st)))" \
 172             "= #t" "test type equal? on equal types"
 173         gdb_test "guile (print (equal? (value-type st) (value-type ar)))" \
 174             "= #f" "test type equal? on not-equal types"
 175
 176         if {$lang == "c++"} {
 177             gdb_scm_test_silent_cmd "guile (define c (parse-and-eval \"c\"))" \
 178                 "get c"
 179             gdb_scm_test_silent_cmd "guile (define d (parse-and-eval \"d\"))" \
 180                 "get d"
 181             gdb_test "guile (print (eq? (value-type c) (field-type (car (type-fields (value-type d))))))" \
 182                 "= #t" "test c++ type eq? on equal types"
 183             gdb_test "guile (print (eq? (value-type c) (value-type d)))" \
 184                 "= #f" "test c++ type eq? on not-equal types"
 185             gdb_test "guile (print (equal? (value-type c) (field-type (car (type-fields (value-type d))))))" \
 186                 "= #t" "test c++ type equal? on equal types"
 187             gdb_test "guile (print (equal? (value-type c) (value-type d)))" \
 188                 "= #f" "test c++ type equal? on not-equal types"
 189         }
 190     }
 191 }
 192
 193 proc test_enums {} {
 194     with_test_prefix "test_enum" {
 195         gdb_scm_test_silent_cmd "print e" "print value, e"
 196         gdb_scm_test_silent_cmd "guile (define e (history-ref 0))" \
 197             "get value (e) from history"
 198         gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type e)))" \
 199             "extract type fields from e"
 200         gdb_test "guile (print (length fields))" \
 201             "= 3" "check the number of enum fields"
 202         gdb_test "guile (print (field-name (car fields)))" \
 203             "= v1" "check enum field\[0\] name"
 204         gdb_test "guile (print (field-name (cadr fields)))" \
 205             "= v2" "check enum field\[1\]name"
 206
 207         # Ditto but by mapping operations.
 208         gdb_test "guile (print (type-num-fields (value-type e)))" \
 209             "= 3" "check the number of enum values"
 210         gdb_test "guile (print (field-name (type-field (value-type e) \"v1\")))" \
 211             "= v1" "check enum field lookup by name, v1"
 212         gdb_test "guile (print (field-name (type-field (value-type e) \"v3\")))" \
 213             "= v3" "check enum field lookup by name, v3"
 214         gdb_test "guile (print (iterator-map field-enumval (make-field-iterator (value-type e))))" \
 215             "\\(0 1 2\\)" "check enum fields iteration"
 216     }
 217 }
 218
 219 proc test_base_class {} {
 220     with_test_prefix "test_base_class" {
 221         gdb_scm_test_silent_cmd "print d" "print value, d"
 222         gdb_scm_test_silent_cmd "guile (define d (history-ref 0))" \
 223             "get value (d) from history"
 224         gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type d)))" \
 225             "extract type fields from d"
 226         gdb_test "guile (print (length fields))" \
 227             "= 3" "check the number of fields"
 228         gdb_test "guile (print (field-baseclass? (car fields)))" \
 229             "= #t" {check base class, fields[0]}
 230         gdb_test "guile (print (field-baseclass? (cadr fields)))" \
 231             "= #f" {check base class, fields[1]}
 232     }
 233 }
 234
 235 proc test_range {} {
 236     with_test_prefix "test_range" {
 237         with_test_prefix "on ranged value" {
 238             # Test a valid range request.
 239             gdb_scm_test_silent_cmd "print ar" "print value, ar"
 240             gdb_scm_test_silent_cmd "guile (define ar (history-ref 0))" \
 241                 "get value (ar) from history"
 242             gdb_test "guile (print (length (type-range (value-type ar))))" \
 243                 "= 2" "check correct tuple length"
 244             gdb_test "guile (print (type-range (value-type ar)))" \
 245                 "= \\(0 1\\)" "check range"
 246         }
 247
 248         with_test_prefix "on unranged value" {
 249             # Test where a range does not exist.
 250             gdb_scm_test_silent_cmd "print st" "print value, st"
 251             gdb_scm_test_silent_cmd "guile (define st (history-ref 0))" \
 252                 "get value (st) from history"
 253             gdb_test "guile (print (type-range (value-type st)))" \
 254                 "ERROR: .*: Wrong type argument in position 1 \\(expecting ranged type\\): .*" \
 255                 "check range for non ranged type"
 256         }
 257
 258         with_test_prefix "on flexible array member" {
 259             gdb_scm_test_silent_cmd "print f" "print value, f"
 260             gdb_scm_test_silent_cmd "guile (define f (history-ref 0))" \
 261                 "get value (f) from history"
 262             gdb_test "guile (print (type-range (field-type (type-field (value-type (value-dereference f)) \"items\"))))" \
 263                 "= \\(0 (0|-1)\\)"
 264             gdb_test "guile (print (value-subscript (value-field (value-dereference f) \"items\") 0))" \
 265                 "= 111"
 266             gdb_test "guile (print (value-subscript (value-field (value-dereference f) \"items\") 1))" \
 267                 "= 222"
 268         }
 269     }
 270 }
 271
 272 # Perform C Tests.
 273
 274 if { [build_inferior "${binfile}" "c"] < 0 } {
 275     return
 276 }
 277 if ![restart_gdb "${binfile}"] {
 278     return
 279 }
 280
 281 with_test_prefix "lang_c" {
 282     runto_bp "break to inspect struct and array."
 283     test_fields "c"
 284     test_equality "c"
 285     test_enums
 286 }
 287
 288 # Perform C++ Tests.
 289
 290 if { [build_inferior "${binfile}-cxx" "c++"] < 0 } {
 291     return
 292 }
 293 if ![restart_gdb "${binfile}-cxx"] {
 294     return
 295 }
 296
 297 with_test_prefix "lang_cpp" {
 298     runto_bp "break to inspect struct and array."
 299     test_fields "c++"
 300     test_base_class
 301     test_range
 302     test_equality "c++"
 303     test_enums
 304 }