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

   1 # Copyright (C) 2009-2022 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 if [get_compiler_info c++] {
  24     return -1
  25 }
  26
  27 # Build inferior to language specification.
  28
  29 proc 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
  42 proc 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" 0
  59
  60     return 1
  61 }
  62
  63 # Set breakpoint and run to that breakpoint.
  64
  65 proc runto_bp {bp} {
  66     gdb_breakpoint [gdb_get_line_number $bp]
  67     gdb_continue_to_breakpoint $bp
  68 }
  69
  70 proc 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
 168 proc 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 equal? on equal types"
 180         gdb_test "guile (print (equal? (value-type st) (value-type ar)))" \
 181             "= #f" "test type equal? 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
 200 proc 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
 226 proc 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
 242 proc 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         with_test_prefix "on flexible array member" {
 266             gdb_scm_test_silent_cmd "print f" "print value (f)"
 267             gdb_scm_test_silent_cmd "guile (define f (history-ref 0))" \
 268                 "get value (f) from history"
 269             gdb_test "guile (print (type-range (field-type (type-field (value-type (value-dereference f)) \"items\"))))" \
 270                 "= \\(0 0\\)"
 271             gdb_test "guile (print (value-subscript (value-field (value-dereference f) \"items\") 0))" \
 272                 "= 111"
 273             gdb_test "guile (print (value-subscript (value-field (value-dereference f) \"items\") 1))" \
 274                 "= 222"
 275         }
 276     }
 277 }
 278
 279 # Perform C Tests.
 280
 281 if { [build_inferior "${binfile}" "c"] < 0 } {
 282     return
 283 }
 284 if ![restart_gdb "${binfile}"] {
 285     return
 286 }
 287
 288 with_test_prefix "lang_c" {
 289     runto_bp "break to inspect struct and array."
 290     test_fields "c"
 291     test_equality "c"
 292     test_enums
 293 }
 294
 295 # Perform C++ Tests.
 296
 297 if { [build_inferior "${binfile}-cxx" "c++"] < 0 } {
 298     return
 299 }
 300 if ![restart_gdb "${binfile}-cxx"] {
 301     return
 302 }
 303
 304 with_test_prefix "lang_cpp" {
 305     runto_bp "break to inspect struct and array."
 306     test_fields "c++"
 307     test_base_class
 308     test_range
 309     test_equality "c++"
 310     test_enums
 311 }