# Copyright 2022-2023 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

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"]

gdb_test_no_output "set language unknown"
gdb_test "p/x 0" \
	"expression parsing not implemented for language \"Unknown\""

# 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
}