374 lines
10 KiB
Text
374 lines
10 KiB
Text
# Copyright 2022 Free Software Foundation, Inc.
|
|
|
|
# This program is free software; you can redistribute it and/or modify
|
|
# it under the terms of the GNU General Public License as published by
|
|
# the Free Software Foundation; either version 3 of the License, or
|
|
# (at your option) any later version.
|
|
#
|
|
# This program is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
# Format hex value VAL for language LANG.
|
|
|
|
proc hex_for_lang { lang val } {
|
|
set neg_p [regexp ^- $val]
|
|
set val [regsub ^-?0x $val ""]
|
|
if { $lang == "modula-2" } {
|
|
set val 0[string toupper $val]H
|
|
} else {
|
|
set val 0x$val
|
|
}
|
|
if { $neg_p } {
|
|
return -$val
|
|
} else {
|
|
return $val
|
|
}
|
|
}
|
|
|
|
# Determine whether N fits in type with TYPE_BITS and TYPE_SIGNEDNESS.
|
|
|
|
proc fits_in_type { n type_bits type_signedness } {
|
|
if { $type_signedness == "s" } {
|
|
set type_signed_p 1
|
|
} elseif { $type_signedness == "u" } {
|
|
set type_signed_p 0
|
|
} else {
|
|
error "unreachable"
|
|
}
|
|
|
|
if { $n < 0 && !$type_signed_p } {
|
|
# Can't fit a negative number in an unsigned type.
|
|
return 0
|
|
}
|
|
|
|
if { $n < 0} {
|
|
set n_sign -1
|
|
set n [expr -$n]
|
|
} else {
|
|
set n_sign 1
|
|
}
|
|
|
|
set smax [expr 1 << ($type_bits - 1)];
|
|
if { $n_sign == -1 } {
|
|
# Negative number, signed type.
|
|
return [expr ($n <= $smax)]
|
|
} elseif { $n_sign == 1 && $type_signed_p } {
|
|
# Positive number, signed type.
|
|
return [expr ($n < $smax)]
|
|
} elseif { $n_sign == 1 && !$type_signed_p } {
|
|
# Positive number, unsigned type.
|
|
return [expr ($n >> $type_bits) == 0]
|
|
} else {
|
|
error "unreachable"
|
|
}
|
|
}
|
|
|
|
# Return 1 if LANG is a c-like language, in the sense that it uses the same
|
|
# parser.
|
|
|
|
proc c_like { lang } {
|
|
set res 0
|
|
switch $lang {
|
|
c
|
|
- c++
|
|
- asm
|
|
- objective-c
|
|
- opencl
|
|
- minimal {set res 1}
|
|
}
|
|
return $res
|
|
}
|
|
|
|
# Parse number N for LANG, and return a list of expected type and value.
|
|
|
|
proc parse_number { lang n } {
|
|
global re_overflow
|
|
|
|
set hex_p [regexp ^-?0x $n]
|
|
|
|
global hex decimal
|
|
if { $hex_p } {
|
|
set any $hex
|
|
} else {
|
|
set any $decimal
|
|
}
|
|
|
|
global sizeof_long_long sizeof_long sizeof_int
|
|
set long_long_bits [expr $sizeof_long_long * 8]
|
|
set long_bits [expr $sizeof_long * 8]
|
|
set int_bits [expr $sizeof_int * 8]
|
|
|
|
if { $lang == "rust" } {
|
|
if { [fits_in_type $n 32 s] } {
|
|
return [list "i32" $n]
|
|
} elseif { [fits_in_type $n 64 s] } {
|
|
return [list "i64" $n]
|
|
} elseif { [fits_in_type $n 64 u] } {
|
|
# Note: Interprets MAX_U64 as -1.
|
|
return [list "i64" $n]
|
|
} else {
|
|
# Overflow.
|
|
return [list $re_overflow $re_overflow]
|
|
}
|
|
} elseif { $lang == "d" } {
|
|
if { [fits_in_type $n 32 s] } {
|
|
return [list int $n]
|
|
} elseif { [fits_in_type $n 32 u] } {
|
|
if { $hex_p } {
|
|
return [list uint $n]
|
|
} else {
|
|
return [list long $n]
|
|
}
|
|
} elseif { [fits_in_type $n 64 s] } {
|
|
return [list long $n]
|
|
} elseif { [fits_in_type $n 64 u] } {
|
|
return [list ulong $n]
|
|
} else {
|
|
# Overflow.
|
|
return [list $re_overflow $re_overflow]
|
|
}
|
|
} elseif { $lang == "ada" } {
|
|
if { [fits_in_type $n $int_bits s] } {
|
|
return [list "<$sizeof_int-byte integer>" $n]
|
|
} elseif { [fits_in_type $n $long_bits s] } {
|
|
return [list "<$sizeof_long-byte integer>" $n]
|
|
} elseif { [fits_in_type $n $long_bits u] } {
|
|
return [list "<$sizeof_long-byte integer>" $n]
|
|
} elseif { [fits_in_type $n $long_long_bits s] } {
|
|
return [list "<$sizeof_long_long-byte integer>" $n]
|
|
} elseif { [fits_in_type $n $long_long_bits u] } {
|
|
# Note: Interprets ULLONG_MAX as -1.
|
|
return [list "<$sizeof_long_long-byte integer>" $n]
|
|
} else {
|
|
# Overflow.
|
|
return [list $re_overflow $re_overflow]
|
|
}
|
|
} elseif { $lang == "modula-2" } {
|
|
if { [string equal $n -0] } {
|
|
# Note: 0 is CARDINAL, but -0 is an INTEGER.
|
|
return [list "INTEGER" 0]
|
|
}
|
|
if { $n < 0 && [fits_in_type $n $int_bits s] } {
|
|
return [list "INTEGER" $n]
|
|
} elseif { [fits_in_type $n $int_bits u] } {
|
|
return [list "CARDINAL" $n]
|
|
} else {
|
|
# Overflow.
|
|
return [list $re_overflow $re_overflow]
|
|
}
|
|
} elseif { $lang == "fortran" } {
|
|
if { [fits_in_type $n $int_bits s] } {
|
|
return [list int $n]
|
|
} elseif { [fits_in_type $n $int_bits u] } {
|
|
return [list "unsigned int" $n]
|
|
} elseif { [fits_in_type $n $long_bits s] } {
|
|
return [list long $n]
|
|
} elseif { [fits_in_type $n $long_bits u] } {
|
|
return [list "unsigned long" $n]
|
|
} else {
|
|
# Overflow.
|
|
return [list $re_overflow $re_overflow]
|
|
}
|
|
} else {
|
|
if { [c_like $lang] } {
|
|
if { $hex_p } {
|
|
# C Hex.
|
|
set have_unsigned 1
|
|
} else {
|
|
# C Decimal. Unsigned not allowed according.
|
|
if { [fits_in_type $n $long_long_bits s] } {
|
|
# Fits in largest signed type.
|
|
set have_unsigned 0
|
|
} else {
|
|
# Doesn't fit in largest signed type, so ill-formed, but
|
|
# allow unsigned as a convenience, as compilers do (though
|
|
# with a warning).
|
|
set have_unsigned 1
|
|
}
|
|
}
|
|
} else {
|
|
# Non-C.
|
|
set have_unsigned 1
|
|
}
|
|
|
|
if { [fits_in_type $n $int_bits s] } {
|
|
return [list int $n]
|
|
} elseif { $have_unsigned && [fits_in_type $n $int_bits u] } {
|
|
return [list "unsigned int" $n]
|
|
} elseif { [fits_in_type $n $long_bits s] } {
|
|
return [list long $n]
|
|
} elseif { $have_unsigned && [fits_in_type $n $long_bits u] } {
|
|
return [list "unsigned long" $n]
|
|
} elseif { [fits_in_type $n $long_long_bits s] } {
|
|
return [list "long long" $n]
|
|
} elseif { $have_unsigned && [fits_in_type $n $long_long_bits u] } {
|
|
return [list "unsigned long long" $n]
|
|
} else {
|
|
# Overflow.
|
|
return [list $re_overflow $re_overflow]
|
|
}
|
|
}
|
|
|
|
error "unreachable"
|
|
}
|
|
|
|
# Test parsing numbers. Several language parsers had the same bug
|
|
# around parsing large 64-bit numbers, hitting undefined behavior, and
|
|
# thus crashing a GDB built with UBSan. This testcase goes over all
|
|
# languages exercising printing the max 64-bit number, making sure
|
|
# that GDB doesn't crash. ARCH is the architecture to test with.
|
|
|
|
proc test_parse_numbers {arch} {
|
|
global full_arch_testing
|
|
global tested_archs
|
|
global verbose
|
|
|
|
set arch_re [string_to_regexp $arch]
|
|
gdb_test "set architecture $arch" "The target architecture is set to \"$arch_re\"."
|
|
|
|
gdb_test_no_output "set language c"
|
|
|
|
# Types have different sizes depending on the architecture.
|
|
# Figure out type sizes before matching patterns in the upcoming
|
|
# tests.
|
|
|
|
global sizeof_long_long sizeof_long sizeof_int sizeof_short
|
|
set sizeof_long_long [get_sizeof "long long" -1]
|
|
set sizeof_long [get_sizeof "long" -1]
|
|
set sizeof_int [get_sizeof "int" -1]
|
|
set sizeof_short [get_sizeof "short" -1]
|
|
|
|
if { ! $full_arch_testing } {
|
|
set arch_id \
|
|
[list $sizeof_long_long $sizeof_long $sizeof_long $sizeof_int \
|
|
$sizeof_short]
|
|
if { [lsearch $tested_archs $arch_id] == -1 } {
|
|
lappend tested_archs $arch_id
|
|
} else {
|
|
return
|
|
}
|
|
}
|
|
|
|
foreach_with_prefix lang $::all_languages {
|
|
if { $lang == "unknown" } {
|
|
# Tested outside $supported_archs loop.
|
|
continue
|
|
} elseif { $lang == "auto" || $lang == "local" } {
|
|
# Avoid duplicate testing.
|
|
continue
|
|
}
|
|
|
|
gdb_test_no_output "set language $lang"
|
|
|
|
global re_overflow
|
|
if { $lang == "modula-2" || $lang == "fortran" } {
|
|
set re_overflow "Overflow on numeric constant\\."
|
|
} elseif { $lang == "ada" } {
|
|
set re_overflow "Integer literal out of range"
|
|
} elseif { $lang == "rust" } {
|
|
set re_overflow "Integer literal is too large"
|
|
} else {
|
|
set re_overflow "Numeric constant too large\\."
|
|
}
|
|
|
|
set basevals {
|
|
0xffffffffffffffff
|
|
0x7fffffffffffffff
|
|
0xffffffff
|
|
0x7fffffff
|
|
0xffff
|
|
0x7fff
|
|
0xff
|
|
0x7f
|
|
0x0
|
|
}
|
|
|
|
if { $lang == "modula-2" } {
|
|
# Modula-2 is the only language that changes the type of an
|
|
# integral literal based on whether it's prefixed with "-",
|
|
# so test both scenarios.
|
|
set prefixes { "" "-" }
|
|
} else {
|
|
# For all the other languages, we'd just be testing the
|
|
# parsing twice, so just test the basic scenario of no prefix.
|
|
set prefixes { "" }
|
|
}
|
|
|
|
foreach_with_prefix prefix $prefixes {
|
|
foreach baseval $basevals {
|
|
foreach offset { -2 -1 0 1 2 } {
|
|
set dec_val [expr $baseval + $offset]
|
|
set hex_val [format "0x%llx" $dec_val]
|
|
if { $dec_val < 0 } {
|
|
continue
|
|
}
|
|
|
|
set dec_val $prefix$dec_val
|
|
lassign [parse_number $lang $dec_val] type out
|
|
if { $verbose >= 1 } { verbose -log "EXPECTED: $out" 2 }
|
|
if { $prefix == "" } {
|
|
gdb_test "p/u $dec_val" "$out"
|
|
} else {
|
|
gdb_test "p/d $dec_val" "$out"
|
|
}
|
|
if { $verbose >= 1 } { verbose -log "EXPECTED: $type" 2 }
|
|
gdb_test "ptype $dec_val" "$type"
|
|
|
|
if { $prefix == "-" } {
|
|
# Printing with /x below means negative numbers are
|
|
# converted to unsigned representation. We could
|
|
# support this by updating the expected patterns.
|
|
# Possibly, we could print with /u and /d instead of
|
|
# /x here as well (which would also require updating
|
|
# expected patterns).
|
|
# For now, this doesn't seem worth the trouble,
|
|
# so skip.
|
|
continue
|
|
}
|
|
|
|
set hex_val $prefix$hex_val
|
|
lassign [parse_number $lang $hex_val] type out
|
|
set hex_val [hex_for_lang $lang $hex_val]
|
|
if { $verbose >= 1 } { verbose -log "EXPECTED: $out" 2 }
|
|
gdb_test "p/x $hex_val" "$out"
|
|
if { $verbose >= 1 } { verbose -log "EXPECTED: $type" 2 }
|
|
gdb_test "ptype $hex_val" "$type"
|
|
}
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
clean_restart
|
|
|
|
gdb_test_no_output "set language unknown"
|
|
gdb_test "p/x 0" \
|
|
"expression parsing not implemented for language \"Unknown\""
|
|
|
|
gdb_test_no_output "set max-completions unlimited"
|
|
|
|
set supported_archs [get_set_option_choices "set architecture"]
|
|
# There should be at least one more than "auto".
|
|
gdb_assert {[llength $supported_archs] > 1} "at least one architecture"
|
|
|
|
set all_languages [get_set_option_choices "set language"]
|
|
|
|
# If 1, test each arch. If 0, test one arch for each sizeof
|
|
# short/int/long/longlong configuration.
|
|
# For a build with --enable-targets=all, full_arch_testing == 0 takes 15s,
|
|
# while full_arch_testing == 1 takes 9m20s.
|
|
set full_arch_testing 0
|
|
|
|
set tested_archs {}
|
|
foreach_with_prefix arch $supported_archs {
|
|
if {$arch == "auto"} {
|
|
# Avoid duplicate testing.
|
|
continue
|
|
}
|
|
test_parse_numbers $arch
|
|
}
|