gdb/testsuite/gdb.base/parse_number.exp

   1 # Copyright 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 # Format hex value VAL for language LANG.
  17
  18 proc hex_for_lang { lang val } {
  19     set neg_p [regexp ^- $val]
  20     set val [regsub ^-?0x $val ""]
  21     if { $lang == "modula-2" } {
  22        set val 0[string toupper $val]H
  23     } else {
  24        set val 0x$val
  25     }
  26     if { $neg_p } {
  27         return -$val
  28     } else {
  29         return $val
  30     }
  31 }
  32
  33 # Determine whether N fits in type with TYPE_BITS and TYPE_SIGNEDNESS.
  34
  35 proc fits_in_type { n type_bits type_signedness } {
  36     if { $type_signedness == "s" } {
  37         set type_signed_p 1
  38     } elseif { $type_signedness == "u" } {
  39         set type_signed_p 0
  40     } else {
  41         error "unreachable"
  42     }
  43
  44     if { $n < 0 && !$type_signed_p } {
  45         # Can't fit a negative number in an unsigned type.
  46         return 0
  47     }
  48
  49     if { $n < 0} {
  50         set n_sign -1
  51         set n [expr -$n]
  52     } else {
  53         set n_sign 1
  54     }
  55
  56     set smax [expr 1 << ($type_bits - 1)];
  57     if  { $n_sign == -1 } {
  58         # Negative number, signed type.
  59         return [expr ($n <= $smax)]
  60     } elseif { $n_sign == 1 && $type_signed_p } {
  61         # Positive number, signed type.
  62         return [expr ($n < $smax)]
  63     } elseif { $n_sign == 1 && !$type_signed_p } {
  64         # Positive number, unsigned type.
  65         return [expr ($n >> $type_bits) == 0]
  66     } else {
  67         error "unreachable"
  68     }
  69 }
  70
  71 # Return 1 if LANG is a c-like language, in the sense that it uses the same
  72 # parser.
  73
  74 proc c_like { lang } {
  75     set res 0
  76     switch $lang {
  77         c
  78         - c++
  79         - asm
  80         - objective-c
  81         - opencl
  82         - minimal {set res 1}
  83     }
  84     return $res
  85 }
  86
  87 # Parse number N for LANG, and return a list of expected type and value.
  88
  89 proc parse_number { lang n } {
  90     global re_overflow
  91
  92     set hex_p [regexp ^-?0x $n]
  93
  94     global hex decimal
  95     if { $hex_p } {
  96         set any $hex
  97     } else {
  98         set any $decimal
  99     }
 100
 101     global sizeof_long_long sizeof_long sizeof_int
 102     set long_long_bits [expr $sizeof_long_long * 8]
 103     set long_bits [expr $sizeof_long * 8]
 104     set int_bits [expr $sizeof_int * 8]
 105
 106     if { $lang == "rust" } {
 107         if { [fits_in_type $n 32 s] } {
 108             return [list "i32" $n]
 109         } elseif { [fits_in_type $n 64 s] } {
 110             return [list "i64" $n]
 111         } elseif { [fits_in_type $n 64 u] } {
 112             # Note: Interprets MAX_U64 as -1.
 113             return [list "i64" $n]
 114         } else {
 115             # Overflow.
 116             # Some truncated value, should be re_overflow.
 117             return [list i64 $any]
 118         }
 119     } elseif { $lang == "d" } {
 120         if { [fits_in_type $n 32 s] } {
 121             return [list int $n]
 122         } elseif { [fits_in_type $n 32 u] } {
 123             if { $hex_p } {
 124                 return [list uint $n]
 125             } else {
 126                 return [list long $n]
 127             }
 128         } elseif { [fits_in_type $n 64 s] } {
 129             return [list long $n]
 130         } elseif { [fits_in_type $n 64 u] } {
 131             return [list ulong $n]
 132         } else {
 133             # Overflow.
 134             return [list $re_overflow $re_overflow]
 135         }
 136     } elseif { $lang == "ada" } {
 137         if { [fits_in_type $n $int_bits s] } {
 138             return [list "<$sizeof_int-byte integer>" $n]
 139         } elseif { [fits_in_type $n $long_bits s] } {
 140             return [list "<$sizeof_long-byte integer>" $n]
 141         } elseif { [fits_in_type $n $long_bits u] } {
 142             return [list "<$sizeof_long-byte integer>" $n]
 143         } elseif { [fits_in_type $n $long_long_bits s] } {
 144             return [list "<$sizeof_long_long-byte integer>" $n]
 145         } elseif { [fits_in_type $n $long_long_bits u] } {
 146             # Note: Interprets ULLONG_MAX as -1.
 147             return [list "<$sizeof_long_long-byte integer>" $n]
 148         } else {
 149             # Overflow.
 150             # Some truncated value or re_overflow, should be re_overflow.
 151             return [list "($re_overflow|<$decimal-byte integer>)" \
 152                         ($re_overflow|$any)]
 153         }
 154     } elseif { $lang == "modula-2" } {
 155         if { [string equal $n -0] } {
 156             # Note: 0 is CARDINAL, but -0 is an INTEGER.
 157             return [list "INTEGER" 0]
 158         }
 159         if { $n < 0 && [fits_in_type $n $int_bits s] } {
 160             return [list "INTEGER" $n]
 161         } elseif { [fits_in_type $n $int_bits u] } {
 162             return [list "CARDINAL" $n]
 163         } else {
 164             # Overflow.
 165             # Some truncated value or re_overflow, should be re_overflow.
 166             return [list ($re_overflow|CARDINAL|INTEGER) ($re_overflow|$any)]
 167         }
 168     } elseif { $lang == "fortran" } {
 169         if { [fits_in_type $n $int_bits s] } {
 170             return [list int $n]
 171         } elseif { [fits_in_type $n $int_bits u] } {
 172             return [list "unsigned int" $n]
 173         } elseif { [fits_in_type $n $long_bits s] } {
 174             return [list long $n]
 175         } elseif { [fits_in_type $n $long_bits u] } {
 176             return [list "unsigned long" $n]
 177         } else {
 178             # Overflow.
 179             # Some truncated value or re_overflow, should be re_overflow.
 180             return [list "((unsigned )?(int|long)|$re_overflow)" \
 181                         ($any|$re_overflow)]
 182         }
 183     } else {
 184         if { [c_like $lang] } {
 185             if { $hex_p } {
 186                 # C Hex.
 187                 set have_unsigned 1
 188             } else {
 189                 # C Decimal.  Unsigned not allowed according.
 190                 if { [fits_in_type $n $long_long_bits s] } {
 191                     # Fits in largest signed type.
 192                     set have_unsigned 0
 193                 } else {
 194                     # Doesn't fit in largest signed type, so ill-formed, but
 195                     # allow unsigned as a convenience, as compilers do (though
 196                     # with a warning).
 197                     set have_unsigned 1
 198                 }
 199             }
 200         } else {
 201             # Non-C.
 202             set have_unsigned 1
 203         }
 204
 205         if { [fits_in_type $n $int_bits s] } {
 206             return [list int $n]
 207         } elseif { $have_unsigned && [fits_in_type $n $int_bits u] } {
 208             return [list "unsigned int" $n]
 209         } elseif { [fits_in_type $n $long_bits s] } {
 210             return [list long $n]
 211         } elseif { $have_unsigned && [fits_in_type $n $long_bits u] } {
 212             return [list "unsigned long" $n]
 213         } elseif { [fits_in_type $n $long_long_bits s] } {
 214             return [list "long long" $n]
 215         } elseif { $have_unsigned && [fits_in_type $n $long_long_bits u] } {
 216             return [list "unsigned long long" $n]
 217         } else {
 218             # Overflow.
 219             if { [c_like $lang] } {
 220                 return [list $re_overflow $re_overflow]
 221             } else {
 222                 # Some truncated value or re_overflow, should be re_overflow.
 223                 return [list "((unsigned )?(int|long)|$re_overflow)" \
 224                             ($any|$re_overflow)]
 225             }
 226         }
 227     }
 228
 229     error "unreachable"
 230 }
 231
 232 # Test parsing numbers.  Several language parsers had the same bug
 233 # around parsing large 64-bit numbers, hitting undefined behavior, and
 234 # thus crashing a GDB built with UBSan.  This testcase goes over all
 235 # languages exercising printing the max 64-bit number, making sure
 236 # that GDB doesn't crash.  ARCH is the architecture to test with.
 237
 238 proc test_parse_numbers {arch} {
 239     global full_arch_testing
 240     global tested_archs
 241     global verbose
 242
 243     set arch_re [string_to_regexp $arch]
 244     gdb_test "set architecture $arch" "The target architecture is set to \"$arch_re\"."
 245
 246     gdb_test_no_output "set language c"
 247
 248     # Types have different sizes depending on the architecture.
 249     # Figure out type sizes before matching patterns in the upcoming
 250     # tests.
 251
 252     global sizeof_long_long sizeof_long sizeof_int sizeof_short
 253     set sizeof_long_long [get_sizeof "long long" -1]
 254     set sizeof_long [get_sizeof "long" -1]
 255     set sizeof_int [get_sizeof "int" -1]
 256     set sizeof_short [get_sizeof "short" -1]
 257
 258     if { ! $full_arch_testing } {
 259         set arch_id \
 260             [list $sizeof_long_long $sizeof_long $sizeof_long $sizeof_int \
 261                  $sizeof_short]
 262         if { [lsearch $tested_archs $arch_id] == -1 } {
 263             lappend tested_archs $arch_id
 264         } else {
 265             return
 266         }
 267     }
 268
 269     foreach_with_prefix lang $::all_languages {
 270         if { $lang == "unknown" } {
 271             # Tested outside $supported_archs loop.
 272             continue
 273         } elseif { $lang == "auto" || $lang == "local" } {
 274             # Avoid duplicate testing.
 275             continue
 276         }
 277
 278         gdb_test_no_output "set language $lang"
 279
 280         global re_overflow
 281         if { $lang == "modula-2" || $lang == "fortran" } {
 282             set re_overflow "Overflow on numeric constant\\."
 283         } elseif { $lang == "ada" } {
 284             set re_overflow "Integer literal out of range"
 285         } else {
 286             set re_overflow "Numeric constant too large\\."
 287         }
 288
 289         set basevals {
 290             0xffffffffffffffff
 291             0x7fffffffffffffff
 292             0xffffffff
 293             0x7fffffff
 294             0xffff
 295             0x7fff
 296             0xff
 297             0x7f
 298             0x0
 299         }
 300
 301         if { $lang == "modula-2" } {
 302             # Modula-2 is the only language that changes the type of an
 303             # integral literal based on whether it's prefixed with "-",
 304             # so test both scenarios.
 305             set prefixes { "" "-" }
 306         } else {
 307             # For all the other languages, we'd just be testing the
 308             # parsing twice, so just test the basic scenario of no prefix.
 309             set prefixes { "" }
 310         }
 311
 312         foreach_with_prefix prefix $prefixes {
 313             foreach baseval $basevals {
 314                 foreach offset { -2 -1 0 1 2 } {
 315                     set dec_val [expr $baseval + $offset]
 316                     set hex_val [format "0x%llx" $dec_val]
 317                     if { $dec_val < 0 } {
 318                         continue
 319                     }
 320
 321                     set dec_val $prefix$dec_val
 322                     lassign [parse_number $lang $dec_val] type out
 323                     if { $verbose >= 1 } { verbose -log "EXPECTED: $out" 2 }
 324                     if { $prefix == "" } {
 325                         gdb_test "p/u $dec_val" "$out"
 326                     } else {
 327                         gdb_test "p/d $dec_val" "$out"
 328                     }
 329                     if { $verbose >= 1 } { verbose -log "EXPECTED: $type" 2 }
 330                     gdb_test "ptype $dec_val" "$type"
 331
 332                     if { $prefix == "-" } {
 333                         # Printing with /x below means negative numbers are
 334                         # converted to unsigned representation.  We could
 335                         # support this by updating the expected patterns.
 336                         # Possibly, we could print with /u and /d instead of
 337                         # /x here as well (which would also require updating
 338                         # expected patterns).
 339                         # For now, this doesn't seem worth the trouble,
 340                         # so skip.
 341                         continue
 342                     }
 343
 344                     set hex_val $prefix$hex_val
 345                     lassign [parse_number $lang $hex_val] type out
 346                     set hex_val [hex_for_lang $lang $hex_val]
 347                     if { $verbose >= 1 } { verbose -log "EXPECTED: $out" 2 }
 348                     gdb_test "p/x $hex_val" "$out"
 349                     if { $verbose >= 1 } { verbose -log "EXPECTED: $type" 2 }
 350                     gdb_test "ptype $hex_val" "$type"
 351                 }
 352             }
 353         }
 354     }
 355 }
 356
 357 clean_restart
 358
 359 gdb_test_no_output "set language unknown"
 360 gdb_test "p/x 0" \
 361         "expression parsing not implemented for language \"Unknown\""
 362
 363 gdb_test_no_output "set max-completions unlimited"
 364
 365 set supported_archs [get_set_option_choices "set architecture"]
 366 # There should be at least one more than "auto".
 367 gdb_assert {[llength $supported_archs] > 1} "at least one architecture"
 368
 369 set all_languages [get_set_option_choices "set language"]
 370
 371 # If 1, test each arch.  If 0, test one arch for each sizeof
 372 # short/int/long/longlong configuration.
 373 # For a build with --enable-targets=all, full_arch_testing == 0 takes 15s,
 374 # while full_arch_testing == 1 takes 9m20s.
 375 set full_arch_testing 0
 376
 377 set tested_archs {}
 378 foreach_with_prefix arch $supported_archs {
 379     if {$arch == "auto"} {
 380         # Avoid duplicate testing.
 381         continue
 382     }
 383     test_parse_numbers $arch
 384 }