diff options
Diffstat (limited to 'gdb/testsuite/lib')
35 files changed, 3249 insertions, 1902 deletions
diff --git a/gdb/testsuite/lib/aarch64-scalable.exp b/gdb/testsuite/lib/aarch64-scalable.exp index c9f2463..e06b339 100644 --- a/gdb/testsuite/lib/aarch64-scalable.exp +++ b/gdb/testsuite/lib/aarch64-scalable.exp @@ -42,7 +42,7 @@ proc sve_value_pattern { state vl byte_fpsimd byte_sve } { append data $brace_open if { $state == "fpsimd" || $state == "za" } { if { $vl > 16 } { - set sve_repeat_count [expr $vl - 16] + set sve_repeat_count [expr {$vl - 16}] append data "$byte_fpsimd <repeats 16 times>, 0 <repeats $sve_repeat_count times>" } else { append data "$byte_fpsimd <repeats 16 times>" @@ -95,7 +95,7 @@ proc state_id_to_state_string { state } { # The state is one of fpsimd, sve, ssve, za and za_ssve. # proc test_id_to_state { id } { - set state [expr $id / 25] + set state [expr {$id / 25}] return [state_id_to_state_string $state] } @@ -104,14 +104,14 @@ proc test_id_to_state { id } { # Given a test ID, return the associated vector length. # proc test_id_to_vl { id } { - return [expr 16 << (($id / 5) % 5)] + return [expr {16 << (($id / 5) % 5)}] } # # Given a test ID, return the associated streaming vector length. # proc test_id_to_svl { id } { - return [expr 16 << ($id % 5)] + return [expr {16 << ($id % 5)}] } # @@ -135,14 +135,14 @@ proc check_sve_regs { byte state vl svl } { if {$vl == 16} { set z_pattern [string_to_regexp [1d_array_value_pattern $byte $vl]] } else { - set z_repeats [expr $vl - 16] + set z_repeats [expr {$vl - 16}] set z_pattern [string_to_regexp "{$byte <repeats 16 times>, 0 <repeats $z_repeats times>}"] } } else { set z_pattern [string_to_regexp [1d_array_value_pattern $byte $vl]] } } - set p_size [expr $z_size / 8] + set p_size [expr {$z_size / 8}] # If there is no SVE/SSVE state, the contents of the Z/P/FFR registers # are zero. @@ -174,7 +174,7 @@ proc check_sme_regs { byte state svl } { # ZA contents are only available when the ZA state is enabled. Otherwise # the ZA contents are unavailable (zeroed out). set za_pattern "" - set expected_za_size [expr $svl * $svl] + set expected_za_size [expr {$svl * $svl}] if {$state != "za" && $state != "za_ssve"} { set byte 0 @@ -217,15 +217,15 @@ proc check_state { state vl svl } { # each byte. # Check VG to make sure it is correct - set expected_vg [expr $vl / 8] + set expected_vg [expr {$vl / 8}] # If streaming mode is enabled, then vg is actually svg. if {$state == "ssve" || $state == "za_ssve"} { - set expected_vg [expr $svl / 8] + set expected_vg [expr {$svl / 8}] } gdb_test "print \$vg" " = ${expected_vg}" # Check SVG to make sure it is correct - set expected_svg [expr $svl / 8] + set expected_svg [expr {$svl / 8}] gdb_test "print \$svg" " = ${expected_svg}" # Check the value of SVCR. @@ -251,7 +251,7 @@ proc check_state { state vl svl } { check_sme_regs 170 $state $svl # Check SME2 registers - if [is_sme2_available] { + if {[is_sme2_available]} { # The SME2 ZT0 register will always be zero, except when ZA is active. set sme2_byte 0 if {$state == "za" || $state == "za_ssve"} { diff --git a/gdb/testsuite/lib/aarch64.exp b/gdb/testsuite/lib/aarch64.exp index ef64489..0d3ed83 100644 --- a/gdb/testsuite/lib/aarch64.exp +++ b/gdb/testsuite/lib/aarch64.exp @@ -78,7 +78,7 @@ proc initialize_1d_array { name byte elements } { append data $byte # If this isn't the last element, add a comma. - if {[expr $element + 1] < $elements} { + if {$element + 1 < $elements} { append data ", " } } @@ -101,7 +101,7 @@ proc initialize_2d_array { name byte rows columns } { set brace_open "{" set brace_close "}" - if {[expr $rows * $columns] <= 256} { + if {$rows * $columns <= 256} { # Build the assignment in a single shot, as we have a maximum of 256 # elements. for {set row 0} {$row < $rows} {incr row} { @@ -111,7 +111,7 @@ proc initialize_2d_array { name byte rows columns } { append data $byte # If this isn't the last column, add a comma. - if {[expr $column + 1] < $columns} { + if {$column + 1 < $columns} { append data ", " } } @@ -119,7 +119,7 @@ proc initialize_2d_array { name byte rows columns } { append data $brace_close # If this isn't the last row, add a comma. - if {[expr $row + 1] < $rows} { + if {$row + 1 < $rows} { append data "," } } diff --git a/gdb/testsuite/lib/ada.exp b/gdb/testsuite/lib/ada.exp index 37bed85..04aaee1 100644 --- a/gdb/testsuite/lib/ada.exp +++ b/gdb/testsuite/lib/ada.exp @@ -111,7 +111,7 @@ proc gdb_compile_ada_1 {source dest type options} { # gdb_compile to determine whether the build has succeeded or not. # We therefore simply check whether the dest file has been created # or not. Unless not present, the build has succeeded. - if [file exists $dest] { set result "" } + if {[file exists $dest]} { set result "" } return $result } @@ -220,7 +220,8 @@ proc gnat_runtime_has_debug_info_1 { shared } { return 0 } - clean_restart $dst + clean_restart + gdb_load $dst if { ! [runto "GNAT_Debug_Info_Test"] } { return 0 diff --git a/gdb/testsuite/lib/cache.exp b/gdb/testsuite/lib/cache.exp index 6ca3f18..f578072 100644 --- a/gdb/testsuite/lib/cache.exp +++ b/gdb/testsuite/lib/cache.exp @@ -24,26 +24,9 @@ proc ignore_pass { msg } { # Call proc real_name and return the result, while ignoring calls to pass. proc gdb_do_cache_wrap {real_name args} { - if { [info procs save_pass] != "" } { - return [uplevel 2 $real_name] + with_override pass ignore_pass { + return [uplevel 2 [list $real_name {*}$args]] } - - rename pass save_pass - rename ignore_pass pass - - set code [catch {uplevel 2 [list $real_name {*}$args]} result] - - rename pass ignore_pass - rename save_pass pass - - if {$code == 1} { - global errorInfo errorCode - return -code error -errorinfo $errorInfo -errorcode $errorCode $result - } elseif {$code > 1} { - return -code $code $result - } - - return $result } # Global written to by gdb_exit_called proc. Is set to true to @@ -295,6 +278,7 @@ proc gdb_do_cache {name args} { proc gdb_caching_proc {name arglist body} { # Define the underlying proc that we'll call. set real_name gdb_real__$name + # tclint-disable-next-line command-args proc $real_name $arglist $body # Define the advertised proc. @@ -303,5 +287,6 @@ proc gdb_caching_proc {name arglist body} { lappend caching_proc_body $$arg } set caching_proc_body [join $caching_proc_body] + # tclint-disable-next-line command-args proc $name $arglist $caching_proc_body } diff --git a/gdb/testsuite/lib/check-test-names.exp b/gdb/testsuite/lib/check-test-names.exp index 049addd..9921172 100644 --- a/gdb/testsuite/lib/check-test-names.exp +++ b/gdb/testsuite/lib/check-test-names.exp @@ -97,7 +97,7 @@ namespace eval ::CheckTestNames { set pos [string first ": " $message] if { $pos > -1 } { # The '+ 2' is so we skip the ': ' we found above. - return [string range $message [expr $pos + 2] end] + return [string range $message [expr {$pos + 2}] end] } return $message @@ -120,11 +120,11 @@ namespace eval ::CheckTestNames { proc check { message } { set message [ _strip_status $message ] - if [ _check_paths $message ] { + if {[ _check_paths $message ]} { clone_output "PATH: $message" } - if [ _check_duplicates $message ] { + if {[ _check_duplicates $message ]} { clone_output "DUPLICATE: $message" } @@ -146,7 +146,7 @@ namespace eval ::CheckTestNames { # If ARGS is the empty list then we don't want to pass a single # empty string as a parameter here. - eval "CheckTestNames::log_summary $args" + CheckTestNames::log_summary {*}$args if { [llength $args] == 0 } { set which "count" @@ -184,10 +184,10 @@ foreach nm {pass fail xfail kfail xpass kpass unresolved untested \ # Create new global log_summary to replace Dejagnu's. proc log_summary { args } { - eval "CheckTestNames::do_log_summary $args" + CheckTestNames::do_log_summary {*}$args } # Create new global reset_vars to replace Dejagnu's. proc reset_vars {} { - eval "CheckTestNames::do_reset_vars" + CheckTestNames::do_reset_vars } diff --git a/gdb/testsuite/lib/compile-support.exp b/gdb/testsuite/lib/compile-support.exp index dd0b9a9..8472d8d 100644 --- a/gdb/testsuite/lib/compile-support.exp +++ b/gdb/testsuite/lib/compile-support.exp @@ -265,7 +265,7 @@ namespace eval ::CompileExpression { if {[string match $cmd "print"]} { if {!$is_explicit} { - eval setup_failures_ $fail_print + setup_failures_ {*}$fail_print return [compile_command_ "compile print $exp" $result $tst] } } else { @@ -274,11 +274,11 @@ namespace eval ::CompileExpression { } else { set command "compile code $varName_ = $exp" } - eval setup_failures_ $fail_compile + setup_failures_ {*}$fail_compile if {![compile_command_ $command "" $tst]} { return 0 } - eval setup_failures_ $fail_value + setup_failures_ {*}$fail_value gdb_test "p $varName_" "= $result" "result of $tst" } return 1 @@ -292,11 +292,11 @@ namespace eval ::CompileExpression { proc setup_failures_ {how args} { switch -nocase $how { xfail { - eval setup_xfail $args + setup_xfail {*}$args } kfail { - eval setup_kfail $args + setup_kfail {*}$args } default { diff --git a/gdb/testsuite/lib/completion-support.exp b/gdb/testsuite/lib/completion-support.exp index 15f59e6..8ddf53d 100644 --- a/gdb/testsuite/lib/completion-support.exp +++ b/gdb/testsuite/lib/completion-support.exp @@ -400,7 +400,7 @@ proc index_after {needle haystack} { if {$start == -1} { error "could not find \"$needle\" in \"$haystack\"" } - return [expr $start + [string length $needle]] + return [expr {$start + [string length $needle]}] } # Create a breakpoint using BREAK_COMMAND, and return the number diff --git a/gdb/testsuite/lib/cp-support.exp b/gdb/testsuite/lib/cp-support.exp index 40351c6..ded4cf8 100644 --- a/gdb/testsuite/lib/cp-support.exp +++ b/gdb/testsuite/lib/cp-support.exp @@ -41,7 +41,8 @@ set ::debug_cp_test_ptype_class false proc cp_check_errata { expected_string actual_string errata_table } { foreach erratum $errata_table { if { "$expected_string" == [lindex $erratum 0] - && "$actual_string" == [lindex $erratum 1] } then { + && "$actual_string" == [lindex $erratum 1] } { + # tclint-disable-next-line command-args eval [lindex $erratum 2] } } @@ -156,7 +157,7 @@ namespace eval ::cp_support_internal { # format of the errata table. Note: the errata entries are not subject to # demangler syntax adjustment, so you have to make a bigger table # with lines for each output variation. -# +# # IN_PTYPE_ARG are arguments to pass to ptype. The default is "/r". # # RECURSIVE_QID is used internally to call this procedure recursively @@ -231,7 +232,7 @@ namespace eval ::cp_support_internal { # gcc 3.4.1 -gstabs+ # gcc HEAD 20040731 -gdwarf-2 # gcc HEAD 20040731 -gstabs+ -# +# # TODO # # Tagless structs. @@ -705,7 +706,7 @@ proc cp_test_ptype_class { in_exp in_testname in_key in_tag in_class_table # Update the count in list_synth. - incr synth_count + incr synth_count set synth [list $synth_count $synth_access "$synth_re"] set list_synth [lreplace $list_synth $isynth $isynth $synth] diff --git a/gdb/testsuite/lib/d-support.exp b/gdb/testsuite/lib/d-support.exp index 717d88b..0714b40 100644 --- a/gdb/testsuite/lib/d-support.exp +++ b/gdb/testsuite/lib/d-support.exp @@ -17,11 +17,12 @@ # The result is 1 (true) for success, 0 (false) for failure. proc set_lang_d {} { - if [gdb_test_no_output "set language d"] { + if {[gdb_test_no_output "set language d"]} { return 0 } - if [gdb_test "show language" ".* source language is \"d\"." \ - "set language to \"d\""] { + if {[gdb_test "show language" \ + [string_to_regexp {The current source language is "d".}] \ + {set language to "d"}]} { return 0 } return 1 diff --git a/gdb/testsuite/lib/dap-support.exp b/gdb/testsuite/lib/dap-support.exp index d61b1c4..5c078ca 100644 --- a/gdb/testsuite/lib/dap-support.exp +++ b/gdb/testsuite/lib/dap-support.exp @@ -117,6 +117,7 @@ proc dap_to_ton {obj} { # Format the object OBJ, in TON format, as JSON and send it to gdb. proc _dap_send_ton {obj} { + # tclint-disable-next-line command-args set json [namespace eval ton::2json $obj] # FIXME this is wrong for non-ASCII characters. set len [string length $json] @@ -170,7 +171,7 @@ proc _dap_read_json {} { } if {$seen_timeout} { - error "timeout reading json header" + error "timeout reading json header" } if {$seen_eof} { error "eof reading json header" @@ -200,7 +201,7 @@ proc _dap_read_json {} { } if {$seen_timeout} { - error "timeout reading json header" + error "timeout reading json header" } if {$seen_eof} { error "eof reading json header" @@ -211,6 +212,7 @@ proc _dap_read_json {} { global last_ton set last_ton [ton::json2ton $json] + # tclint-disable-next-line command-args return [namespace eval ton::2dict $last_ton] } @@ -229,9 +231,9 @@ proc dap_read_response {cmd num} { set d [_dap_read_json] if {[dict get $d type] == "response"} { if {[dict get $d request_seq] != $num} { - error "saw wrong request_seq in $obj" + error "saw wrong request_seq in $d" } elseif {[dict get $d command] != $cmd} { - error "saw wrong command in $obj" + error "saw wrong command in $d" } else { return [list $d $result] } @@ -443,7 +445,7 @@ proc dap_search_output {name rx events} { # key/value pairs given in ARGS. NAME is used as the test name. proc dap_match_values {name d args} { foreach {key value} $args { - if {[eval dict get [list $d] $key] != $value} { + if {[dict get $d {*}$key] != $value} { fail "$name (checking $key)" return "" } @@ -494,7 +496,7 @@ proc dap_wait_for_event_and_check {name type args} { set result [_dap_wait_for_event $type] set event [lindex $result 0] - eval dap_match_values [list $name $event] $args + dap_match_values $name $event {*}$args return $result } diff --git a/gdb/testsuite/lib/debuginfod-support.exp b/gdb/testsuite/lib/debuginfod-support.exp index 674888a..ad6963e 100644 --- a/gdb/testsuite/lib/debuginfod-support.exp +++ b/gdb/testsuite/lib/debuginfod-support.exp @@ -18,7 +18,7 @@ # Return true if the debuginfod tests should be run, otherwise, return # false. proc allow_debuginfod_tests {} { - if [is_remote host] { + if {[is_remote host]} { return false } @@ -37,7 +37,7 @@ proc allow_debuginfod_tests {} { # (installed by ASan) exist on startup. That makes TCL's exec throw an # error. This is dealt with by the --quiet in INTERNAL_GDBFLAGS. if { [string first "with-debuginfod" \ - [eval exec $::GDB $::INTERNAL_GDBFLAGS \ + [exec $::GDB {*}$::INTERNAL_GDBFLAGS \ --configuration]] == -1 } { return false } @@ -189,7 +189,7 @@ proc start_debuginfod { db debugdir } { proc stop_debuginfod { } { global debuginfod_spawn_id - if [info exists debuginfod_spawn_id] { + if {[info exists debuginfod_spawn_id]} { kill_wait_spawned_process $debuginfod_spawn_id unset debuginfod_spawn_id } diff --git a/gdb/testsuite/lib/dtrace.exp b/gdb/testsuite/lib/dtrace.exp index d558aba..2456ba9 100644 --- a/gdb/testsuite/lib/dtrace.exp +++ b/gdb/testsuite/lib/dtrace.exp @@ -32,7 +32,7 @@ # This function returns -1 on failure, 0 otherwise proc dtrace_build_usdt_test_program {} { global testfile hex objdir srcdir srcfile subdir binfile - + # Make sure that dtrace is installed, it is the real one (not the # script installed by SystemTap, for example) and of the right # version (>= 0.4.0). If it is not then use pdtrace instead. diff --git a/gdb/testsuite/lib/dwarf.exp b/gdb/testsuite/lib/dwarf.exp index 46b39a1..55f33d4 100644 --- a/gdb/testsuite/lib/dwarf.exp +++ b/gdb/testsuite/lib/dwarf.exp @@ -36,7 +36,7 @@ proc extract_dwo_information { object_file dwo_file } { set objcopy [gdb_find_objcopy] set command "$objcopy --extract-dwo $object_file $dwo_file" verbose -log "Executing $command" - set result [catch "exec $command" output] + set result [catch {exec {*}$command} output] verbose -log "objcopy --extract-dwo output: $output" if { $result == 1 } { return -1 @@ -52,7 +52,7 @@ proc strip_dwo_information { filename } { set objcopy [gdb_find_objcopy] set command "$objcopy --strip-dwo $filename" verbose -log "Executing $command" - set result [catch "exec $command" output] + set result [catch {exec {*}$command} output] verbose -log "objcopy --strip-dwo output: $output" if { $result == 1 } { return -1 @@ -126,7 +126,7 @@ proc build_executable_and_dwo_files { testname executable options args } { } # Must be run on local host due to use of objcopy. - if [is_remote host] { + if {[is_remote host]} { return -1 } @@ -406,7 +406,7 @@ proc function_range { func src {options {debug}} } { set start $expect_out(1,string) set end $expect_out(2,string) - set func_length [expr $func_length + $end - $start] + set func_length [expr {$func_length + $end - $start}] } } @@ -461,16 +461,13 @@ proc get_func_info { name {options {debug}} } { # # proc DW_TAG_mumble {{attrs {}} {children {}}} { ... } # -# ATTRS is an optional list of attributes. -# It is run through 'subst' in the caller's context before processing. +# ATTRS holds optional attributes. It is just Tcl code and is +# evaluated in the caller's context. Each attribute is a proc of the +# form: # -# Each attribute in the list has one of two forms: -# 1. { NAME VALUE } -# 2. { NAME VALUE FORM } +# proc DW_AT_mumble {value {form {}}} { ... } # -# In each case, NAME is the attribute's name. -# This can either be the full name, like 'DW_AT_name', or a shortened -# name, like 'name'. These are fully equivalent. +# Only the full name can be used here. # # Besides DWARF standard attributes, assembler supports 'macro' attribute # which will be substituted by one or more standard or macro attributes. @@ -491,10 +488,9 @@ proc get_func_info { name {options {debug}} } { # section automatically. # # If FORM is 'SPECIAL_expr', then VALUE is treated as a location -# expression. The effective form is then DW_FORM_block or DW_FORM_exprloc -# for DWARF version >= 4, and VALUE is passed to the (internal) -# '_location' proc to be translated. -# This proc implements a miniature DW_OP_ assembler. +# expression. The effective form is then DW_FORM_block or +# DW_FORM_exprloc for DWARF version >= 4, and VALUE is treated as +# code, using DW_OP_* procs and evaluated in the appropriate scope. # # If FORM is not given, it is guessed: # * If VALUE starts with the "@" character, the rest of VALUE is @@ -522,12 +518,8 @@ namespace eval Dwarf { # Constants from dwarf2.h. variable _constants - # DW_AT short names. - variable _AT # DW_FORM short names. variable _FORM - # DW_OP short names. - variable _OP # The current output file. variable _output_file @@ -592,11 +584,19 @@ namespace eval Dwarf { # otherwise false. variable _cu_is_fission + # When assembling, this is used to stash the level in which any + # code should be evaluated. + variable _level + + # Variables used when processing a location expression. These are + # set by _location and may be used by the various DW_OP-handlers. + variable _loc_dwarf_version + variable _loc_addr_size + variable _loc_offset_size + proc _process_one_constant {name value} { variable _constants - variable _AT variable _FORM - variable _OP set _constants($name) $value @@ -616,6 +616,7 @@ namespace eval Dwarf { # Create two procedures for the tag. These call # _handle_DW_TAG with the full tag name baked in; this # does all the actual work. + # tclint-disable-next-line command-args proc $name {{attrs {}} {children {}}} \ "_handle_DW_TAG $name \$attrs \$children" @@ -628,12 +629,15 @@ namespace eval Dwarf { error "duplicate proc name: from $name" } + # tclint-disable-next-line command-args proc $name2 {{attrs {}} {children {}}} \ "_handle_DW_TAG $name \$attrs \$children" } AT { - set _AT($name2) $name + # tclint-disable-next-line command-args + proc $name {value {form {}}} \ + "_handle_DW_AT $name \$value \$form" } FORM { @@ -641,7 +645,18 @@ namespace eval Dwarf { } OP { - set _OP($name2) $name + set handler _handle_default_OP + if {[llength [info procs _handle_DW_OP_$name2]] > 0} { + set handler _handle_DW_OP_$name2 + } + # Each DW_OP_* proc emits the opcode and then + # delegates to the argument handler. + # tclint-disable-next-line command-args + proc $name {args} [format { + variable _constants + _op .byte $_constants(%s) %s + %s {*}$args + } $name $name $handler] } default { @@ -678,6 +693,11 @@ namespace eval Dwarf { } } close $fd + + variable _constants + + # Add DW_FORM_strx_id as alias of DW_FORM_strx. + _process_one_constant DW_FORM_strx_id $_constants(DW_FORM_strx) } proc _quote {string} { @@ -823,6 +843,12 @@ namespace eval Dwarf { DW_FORM_indirect - DW_FORM_exprloc - + # Generate a DW_FORM_str index, but assume generation of .debug_str and + # .debug_str_offsets is taken care of elsewhere. + DW_FORM_strx_id { + _op .uleb128 $value + } + DW_FORM_strx - DW_FORM_strx1 - DW_FORM_strx2 - @@ -906,11 +932,27 @@ namespace eval Dwarf { return $name } - proc _handle_attribute { attr_name attr_value attr_form } { + # Implementation of all the DW_AT_* procs. + proc _handle_DW_AT {attr_name attr_value attr_form} { variable _abbrev_section variable _constants variable _cu_version + if {$attr_form == ""} { + set attr_form [_guess_form $attr_value attr_value] + if { $attr_form eq "" } { + set attr_form [_default_form $attr_name] + } + if { $attr_form eq "" } { + error "No form for $attr_name $attr_value" + } + } elseif { [string index $attr_value 0] == ":" } { + # It is a label, get its value. + _guess_form $attr_value attr_value + } + + set attr_form [_map_name $attr_form _FORM] + _handle_DW_FORM $attr_form $attr_value _defer_output $_abbrev_section { @@ -931,9 +973,8 @@ namespace eval Dwarf { } } - # Handle macro attribute MACRO_AT_range. - - proc _handle_macro_at_range { attr_value } { + # Handle extension attribute MACRO_AT_range. + proc MACRO_AT_range { attr_value } { variable _cu_is_fission if {[llength $attr_value] != 1} { @@ -950,19 +991,17 @@ namespace eval Dwarf { set form DW_FORM_GNU_addr_index } - _handle_attribute DW_AT_low_pc [lindex $result 0] $form - _handle_attribute DW_AT_high_pc \ - "[lindex $result 0] + [lindex $result 1]" $form + DW_AT_low_pc [lindex $result 0] $form + DW_AT_high_pc "[lindex $result 0] + [lindex $result 1]" $form } - # Handle macro attribute MACRO_AT_func. - - proc _handle_macro_at_func { attr_value } { + # Handle extension attribute MACRO_AT_func. + proc MACRO_AT_func { attr_value } { if {[llength $attr_value] != 1} { error "usage: MACRO_AT_func { func file }" } - _handle_attribute DW_AT_name [lindex $attr_value 0] DW_FORM_string - _handle_macro_at_range $attr_value + DW_AT_name [lindex $attr_value 0] DW_FORM_string + MACRO_AT_range $attr_value } # Return the next available abbrev number in the current CU's abbrev @@ -992,47 +1031,8 @@ namespace eval Dwarf { _op .uleb128 $my_abbrev "Abbrev ($tag_name)" - foreach attr $attrs { - set attr_name [_map_name [lindex $attr 0] _AT] - - # When the length of ATTR is greater than 2, the last - # element of the list must be a form. The second through - # the penultimate elements are joined together and - # evaluated using subst. This allows constructs such as - # [gdb_target_symbol foo] to be used. - - if {[llength $attr] > 2} { - set attr_value [uplevel 2 [list subst [join [lrange $attr 1 end-1]]]] - } else { - set attr_value [uplevel 2 [list subst [lindex $attr 1]]] - } - - if { [string equal "MACRO_AT_func" $attr_name] } { - _handle_macro_at_func $attr_value - } elseif { [string equal "MACRO_AT_range" $attr_name] } { - _handle_macro_at_range $attr_value - } else { - if {[llength $attr] > 2} { - set attr_form [uplevel 2 [list subst [lindex $attr end]]] - - if { [string index $attr_value 0] == ":" } { - # It is a label, get its value. - _guess_form $attr_value attr_value - } - } else { - set attr_form [_guess_form $attr_value attr_value] - if { $attr_form eq "" } { - set attr_form [_default_form $attr_name] - } - if { $attr_form eq "" } { - error "No form for $attr_name $attr_value" - } - } - set attr_form [_map_name $attr_form _FORM] - - _handle_attribute $attr_name $attr_value $attr_form - } - } + variable _level + uplevel $_level $attrs _defer_output $_abbrev_section { # Terminator. @@ -1041,7 +1041,7 @@ namespace eval Dwarf { } if {$has_children} { - uplevel 2 $children + uplevel $_level $children # Terminate children. _op .byte 0x0 "Terminate children" @@ -1061,7 +1061,10 @@ namespace eval Dwarf { } proc _section {name {flags ""} {type ""}} { - if {$flags == "" && $type == ""} { + if {$name == ".debug_str"} { + # Hard-code this because it's always desirable. + _emit " .section $name, \"MS\", %progbits, 1" + } elseif {$flags == "" && $type == ""} { _emit " .section $name" } elseif {$type == ""} { _emit " .section $name, \"$flags\"" @@ -1080,7 +1083,7 @@ namespace eval Dwarf { if {![info exists _deferred_output($_defer)]} { set _deferred_output($_defer) "" - eval _section $section_spec + _section {*}$section_spec } uplevel $body @@ -1205,6 +1208,7 @@ namespace eval Dwarf { upvar $name label_var set label_var [new_label $text] + # tclint-disable-next-line command-args proc ${name}: {args} [format { define_label %s uplevel $args @@ -1226,209 +1230,211 @@ namespace eval Dwarf { } } - # This is a miniature assembler for location expressions. It is - # suitable for use in the attributes to a DIE. Its output is - # prefixed with "=" to make it automatically use DW_FORM_block. # - # BODY is split by lines, and each line is taken to be a list. + # Handlers for DW_OP_* opcodes. # - # DWARF_VERSION is the DWARF version for the section where the location - # description is found. + # A handler is only needed if the opcode requires a parameter, or + # some sort of special handling. Generic code handles emitting + # the actual opcode itself, so a handler should not do this. # - # ADDR_SIZE is the length in bytes (4 or 8) of an address on the target - # machine (typically found in the header of the section where the location - # description is found). + # Handlers are found by name when parsing the .def file. If a + # handler isn't found, the default (_handle_default_OP) is used. # - # OFFSET_SIZE is the length in bytes (4 or 8) of an offset into a DWARF - # section. This typically depends on whether 32-bit or 64-bit DWARF is - # used, as indicated in the header of the section where the location - # description is found. - # - # Each list's first element is the opcode, either short or long - # forms are accepted. - # FIXME argument handling - # FIXME move docs - proc _location { body dwarf_version addr_size offset_size } { - variable _constants - set collected_lines "" - foreach line [split $body \n] { - # Ignore blank lines, and allow embedded comments. - if { [regexp -- {^[ \t]*$} $line] || [regexp -- {^[ \t]*#} $line] } { - continue - } - if { $collected_lines != "" } { - set line "$collected_lines\n$line" - set collected_lines "" - } - if { ! [info complete $line] } { - set collected_lines $line - continue - } - set opcode [_map_name [lindex $line 0] _OP] - _op .byte $_constants($opcode) $opcode + proc _handle_DW_OP_addr {size} { + variable _loc_addr_size + _op .${_loc_addr_size}byte $size + } - array unset argvec * - switch -exact -- $opcode { - DW_OP_addr { - _get_args $line $opcode size - _op .${addr_size}byte $argvec(size) - } + proc _handle_DW_OP_GNU_addr_index {symbol} { + variable _debug_addr_index + variable _cu_addr_size - DW_OP_GNU_addr_index { - variable _debug_addr_index - variable _cu_addr_size + _op .uleb128 ${_debug_addr_index} + incr _debug_addr_index - _op .uleb128 ${_debug_addr_index} - incr _debug_addr_index + _defer_output .debug_addr { + _op .${_cu_addr_size}byte $symbol + } + } - _defer_output .debug_addr { - _op .${_cu_addr_size}byte [lindex $line 1] - } - } + proc _handle_DW_OP_regx {register} { + _op .uleb128 $register + } - DW_OP_regx { - _get_args $line $opcode register - _op .uleb128 $argvec(register) - } + proc _handle_DW_OP_pick {const} { + _op .byte $const + } + proc _handle_DW_OP_const1u {const} { + _op .byte $const + } + proc _handle_DW_OP_const1s {const} { + _op .byte $const + } - DW_OP_pick - - DW_OP_const1u - - DW_OP_const1s { - _get_args $line $opcode const - _op .byte $argvec(const) - } + proc _handle_DW_OP_const2u {const} { + _op .2byte $const + } + proc _handle_DW_OP_const2s {const} { + _op .2byte $const + } - DW_OP_const2u - - DW_OP_const2s { - _get_args $line $opcode const - _op .2byte $argvec(const) - } + proc _handle_DW_OP_const4u {const} { + _op .4byte $const + } + proc _handle_DW_OP_const4s {const} { + _op .4byte $const + } - DW_OP_const4u - - DW_OP_const4s { - _get_args $line $opcode const - _op .4byte $argvec(const) - } + proc _handle_DW_OP_const8u {const} { + _op .8byte $const + } + proc _handle_DW_OP_const8s {const} { + _op .8byte $const + } - DW_OP_const8u - - DW_OP_const8s { - _get_args $line $opcode const - _op .8byte $argvec(const) - } + proc _handle_DW_OP_constu {const} { + _op .uleb128 $const + } + proc _handle_DW_OP_consts {const} { + _op .sleb128 $const + } - DW_OP_constu { - _get_args $line $opcode const - _op .uleb128 $argvec(const) - } - DW_OP_consts { - _get_args $line $opcode const - _op .sleb128 $argvec(const) - } + proc _handle_DW_OP_plus_uconst {const} { + _op .uleb128 $const + } - DW_OP_plus_uconst { - _get_args $line $opcode const - _op .uleb128 $argvec(const) - } + proc _handle_DW_OP_piece {size} { + _op .uleb128 $size + } - DW_OP_piece { - _get_args $line $opcode size - _op .uleb128 $argvec(size) - } + proc _handle_DW_OP_bit_piece {size offset} { + _op .uleb128 $size + _op .uleb128 $offset + } - DW_OP_bit_piece { - _get_args $line $opcode size offset - _op .uleb128 $argvec(size) - _op .uleb128 $argvec(offset) - } + proc _handle_DW_OP_skip {label} { + _op .2byte $label + } + proc _handle_DW_OP_bra {label} { + _op .2byte $label + } - DW_OP_skip - - DW_OP_bra { - _get_args $line $opcode label - _op .2byte $argvec(label) - } + proc _handle_DW_OP_entry_value {body} { + variable _loc_dwarf_version + variable _loc_addr_size + variable _loc_offset_size - DW_OP_entry_value { - _get_args $line $opcode body - set l1 [new_label "expr_start"] - set l2 [new_label "expr_end"] - _op .uleb128 "$l2 - $l1" "expression" - define_label $l1 - _location $argvec(body) $dwarf_version $addr_size \ - $offset_size - define_label $l2 - } + set l1 [new_label "expr_start"] + set l2 [new_label "expr_end"] + _op .uleb128 "$l2 - $l1" "expression" + define_label $l1 + variable _level + uplevel $_level [list _location $body $_loc_dwarf_version \ + $_loc_addr_size $_loc_offset_size] + define_label $l2 + } - DW_OP_implicit_value { - set l1 [new_label "value_start"] - set l2 [new_label "value_end"] - _op .uleb128 "$l2 - $l1" - define_label $l1 - foreach value [lrange $line 1 end] { - switch -regexp -- $value { - {^0x[[:xdigit:]]{1,2}$} {_op .byte $value} - {^0x[[:xdigit:]]{4}$} {_op .2byte $value} - {^0x[[:xdigit:]]{8}$} {_op .4byte $value} - {^0x[[:xdigit:]]{16}$} {_op .8byte $value} - default { - error "bad value '$value' in DW_OP_implicit_value" - } - } - } - define_label $l2 + proc _handle_DW_OP_implicit_value {args} { + set l1 [new_label "value_start"] + set l2 [new_label "value_end"] + _op .uleb128 "$l2 - $l1" + define_label $l1 + foreach value $args { + switch -regexp -- $value { + {^0x[[:xdigit:]]{1,2}$} {_op .byte $value} + {^0x[[:xdigit:]]{4}$} {_op .2byte $value} + {^0x[[:xdigit:]]{8}$} {_op .4byte $value} + {^0x[[:xdigit:]]{16}$} {_op .8byte $value} + default { + error "bad value '$value' in DW_OP_implicit_value" } + } + } + define_label $l2 + } - DW_OP_implicit_pointer - - DW_OP_GNU_implicit_pointer { - _get_args $line $opcode label offset + proc _handle_DW_OP_implicit_pointer {label offset} { + variable _loc_dwarf_version + variable _loc_addr_size + variable _loc_offset_size + # Here label is a section offset. + if { $_loc_dwarf_version == 2 } { + _op .${_loc_addr_size}byte $label + } else { + _op_offset $_loc_offset_size $label + } + _op .sleb128 $offset + } - # Here label is a section offset. - if { $dwarf_version == 2 } { - _op .${addr_size}byte $argvec(label) - } else { - _op_offset $offset_size $argvec(label) - } - _op .sleb128 $argvec(offset) - } + proc _handle_DW_OP_GNU_implicit_pointer {label offset} { + _handle_DW_OP_implicit_pointer $label $offset + } - DW_OP_GNU_variable_value { - _get_args $line $opcode label + proc _handle_DW_OP_GNU_variable_value {label} { + variable _loc_addr_size + variable _loc_offset_size + variable _loc_dwarf_version + # Here label is a section offset. + if { $_loc_dwarf_version == 2 } { + _op .${_loc_addr_size}byte $label + } else { + _op_offset $_loc_offset_size $label + } + } - # Here label is a section offset. - if { $dwarf_version == 2 } { - _op .${addr_size}byte $argvec(label) - } else { - _op_offset $offset_size $argvec(label) - } - } + proc _handle_DW_OP_deref_size {size} { + _op .byte $size + } - DW_OP_deref_size { - _get_args $line $opcode size - _op .byte $argvec(size) - } + proc _handle_DW_OP_bregx {register offset} { + _op .uleb128 $register + _op .sleb128 $offset + } - DW_OP_bregx { - _get_args $line $opcode register offset - _op .uleb128 $argvec(register) - _op .sleb128 $argvec(offset) - } + proc _handle_DW_OP_fbreg {offset} { + _op .sleb128 $offset + } - DW_OP_fbreg { - _get_args $line $opcode offset - _op .sleb128 $argvec(offset) - } + proc _handle_DW_OP_fbreg {reg} { + _op .sleb128 $reg + } - DW_OP_fbreg { - _op .sleb128 [lindex $line 1] - } + proc _handle_default_OP {} { + # Do nothing; if arguments are passed, Tcl will cause an + # error. + } - default { - if {[llength $line] > 1} { - error "Unimplemented: operands in location for $opcode" - } - } - } - } + # This is a miniature assembler for location expressions. It is + # suitable for use in the attributes to a DIE. + # + # BODY is evaluated as code in the appropriate scope. + # + # DWARF_VERSION is the DWARF version for the section where the location + # description is found. + # + # ADDR_SIZE is the length in bytes (4 or 8) of an address on the target + # machine (typically found in the header of the section where the location + # description is found). + # + # OFFSET_SIZE is the length in bytes (4 or 8) of an offset into a DWARF + # section. This typically depends on whether 32-bit or 64-bit DWARF is + # used, as indicated in the header of the section where the location + # description is found. + # + # FIXME move docs + proc _location { body dwarf_version addr_size offset_size } { + variable _loc_dwarf_version + set _loc_dwarf_version $dwarf_version + + variable _loc_addr_size + set _loc_addr_size $addr_size + + variable _loc_offset_size + set _loc_offset_size $offset_size + + variable _level + uplevel $_level $body } # Return a label that references the current position in the @@ -1487,6 +1493,7 @@ namespace eval Dwarf { variable _cu_addr_size variable _cu_offset_size variable _cu_is_fission + variable _level # Establish the defaults. set is_64 0 @@ -1499,7 +1506,7 @@ namespace eval Dwarf { set label "" foreach { name value } $options { - set value [uplevel 1 "subst \"$value\""] + set value [uplevel $_level "subst \"$value\""] switch -exact -- $name { is_64 { set is_64 $value } version { set _cu_version $value } @@ -1598,7 +1605,7 @@ namespace eval Dwarf { define_label $my_abbrevs } - uplevel $body + uplevel $_level $body _defer_output $_abbrev_section { # Emit the terminator. @@ -1634,6 +1641,7 @@ namespace eval Dwarf { variable _cu_addr_size variable _cu_offset_size variable _cu_is_fission + variable _level # Establish the defaults. set is_64 0 @@ -1645,7 +1653,7 @@ namespace eval Dwarf { set label "" foreach { name value } $options { - set value [uplevel 1 "subst \"$value\""] + set value [uplevel $_level "subst \"$value\""] switch -exact -- $name { is_64 { set is_64 $value } version { set _cu_version $value } @@ -1708,7 +1716,7 @@ namespace eval Dwarf { _op .8byte $signature Signature if { $type_label != "" } { - uplevel declare_labels $type_label + uplevel $_level declare_labels $type_label upvar $type_label my_type_label if {$is_64} { _op .8byte "$my_type_label - $_cu_label" @@ -1727,7 +1735,7 @@ namespace eval Dwarf { define_label $my_abbrevs } - uplevel $body + uplevel $_level $body _defer_output $_abbrev_section { # Emit the terminator. @@ -1800,7 +1808,8 @@ namespace eval Dwarf { } } - uplevel $body + variable _level + uplevel $_level $body } # Emit a DWARF .debug_rnglists section. @@ -1820,7 +1829,7 @@ namespace eval Dwarf { parse_options {{"is-64" "false"}} - if [is_64_target] { + if {[is_64_target]} { set _debug_rnglists_addr_size 8 } else { set _debug_rnglists_addr_size 4 @@ -1849,7 +1858,8 @@ namespace eval Dwarf { } with_override Dwarf::table Dwarf::_rnglists_table { - uplevel $body + variable _level + uplevel $_level $body } } @@ -1875,6 +1885,7 @@ namespace eval Dwarf { variable _debug_rnglists_addr_size variable _debug_rnglists_offset_size variable _debug_rnglists_is_64_dwarf + variable _level parse_options { {post-header-label ""} @@ -1888,7 +1899,7 @@ namespace eval Dwarf { # lists there are to generate the header and offset table. set lists_ops [_defer_to_string { with_override Dwarf::list_ Dwarf::_rnglists_list { - uplevel $body + uplevel $_level $body } }] @@ -1962,6 +1973,7 @@ namespace eval Dwarf { proc _rnglists_list { body } { variable _debug_rnglists_list_count + variable _level # Define a label for this list. It is used to build the offset # array later. @@ -1969,7 +1981,7 @@ namespace eval Dwarf { define_label $list_label with_override Dwarf::start_end Dwarf::_rnglists_start_end { - uplevel $body + uplevel $_level $body } # Emit end of list. @@ -2005,10 +2017,11 @@ namespace eval Dwarf { variable _debug_loclists_addr_size variable _debug_loclists_offset_size variable _debug_loclists_is_64_dwarf + variable _level parse_options {{"is-64" "false"}} - if [is_64_target] { + if {[is_64_target]} { set _debug_loclists_addr_size 8 } else { set _debug_loclists_addr_size 4 @@ -2037,7 +2050,7 @@ namespace eval Dwarf { } with_override Dwarf::table Dwarf::_loclists_table { - uplevel $body + uplevel $_level $body } } @@ -2063,6 +2076,7 @@ namespace eval Dwarf { variable _debug_loclists_addr_size variable _debug_loclists_offset_size variable _debug_loclists_is_64_dwarf + variable _level parse_options { {post-header-label ""} @@ -2076,7 +2090,7 @@ namespace eval Dwarf { # lists there are to generate the header and offset table. set lists_ops [_defer_to_string { with_override Dwarf::list_ Dwarf::_loclists_list { - uplevel $body + uplevel $_level $body } }] @@ -2152,6 +2166,7 @@ namespace eval Dwarf { proc _loclists_list { body } { variable _debug_loclists_list_count + variable _level # Count the location descriptions in this list. variable _debug_loclists_locdesc_count 0 @@ -2164,7 +2179,7 @@ namespace eval Dwarf { with_override Dwarf::start_length Dwarf::_loclists_start_length { with_override Dwarf::base_address Dwarf::_loclists_base_address { with_override Dwarf::start_end Dwarf::_loclists_start_end { - uplevel $body + uplevel $_level $body }}} # Emit end of list. @@ -2185,8 +2200,9 @@ namespace eval Dwarf { variable _debug_loclists_table_count variable _debug_loclists_list_count variable _debug_loclists_locdesc_count + variable _level - set locdesc [uplevel [list subst $locdesc]] + set locdesc [uplevel $_level [list subst $locdesc]] _op .byte 0x08 "DW_LLE_start_length" @@ -2219,8 +2235,9 @@ namespace eval Dwarf { variable _debug_loclists_table_count variable _debug_loclists_list_count variable _debug_loclists_locdesc_count + variable _level - set locdesc [uplevel [list subst $locdesc]] + set locdesc [uplevel $_level [list subst $locdesc]] _op .byte 0x07 "DW_LLE_start_end" @@ -2257,10 +2274,11 @@ namespace eval Dwarf { # (see `_macro_unit`) to generate macro units. proc macro { body } { + variable _level _section ".debug_macro" with_override Dwarf::unit Dwarf::_macro_unit { - uplevel $body + uplevel $_level $body } } @@ -2296,19 +2314,19 @@ namespace eval Dwarf { set flags 0 if { ${is-64} } { - set flags [expr $flags | 0x1] + set flags [expr {$flags | 0x1}] } variable _mu_offset_size - set _mu_offset_size [expr ${is-64} ? 8 : 4] + set _mu_offset_size [expr {${is-64} ? 8 : 4}] if { ${debug-line-offset-label} != "" } { - set flags [expr $flags | 0x2] + set flags [expr {$flags | 0x2}] } _op .byte $flags "flags" if { ${debug-line-offset-label} != "" } { - _op_offset [expr ${is-64} ? 8 : 4] ${debug-line-offset-label} \ + _op_offset [expr {${is-64} ? 8 : 4}] ${debug-line-offset-label} \ "debug_line offset" } @@ -2316,7 +2334,8 @@ namespace eval Dwarf { with_override Dwarf::define Dwarf::_macro_unit_define { with_override Dwarf::start_file Dwarf::_macro_unit_start_file { with_override Dwarf::end_file Dwarf::_macro_unit_end_file { - uplevel $body + variable _level + uplevel $_level $body }}}} _op .byte 0x0 "# End macro unit" @@ -2508,7 +2527,7 @@ namespace eval Dwarf { lappend _line_include_dirs $dirname if { $Dwarf::_line_unit_version >= 5 } { - return [expr [llength $_line_include_dirs] - 1] + return [expr {[llength $_line_include_dirs] - 1}] } else { return [llength $_line_include_dirs] } @@ -2521,9 +2540,9 @@ namespace eval Dwarf { variable _line_file_names lappend _line_file_names $filename $diridx - set nr_filenames [expr [llength $_line_file_names] / 2] + set nr_filenames [expr {[llength $_line_file_names] / 2}] if { $Dwarf::_line_unit_version >= 5 } { - return [expr $nr_filenames - 1] + return [expr {$nr_filenames - 1}] } else { return $nr_filenames } @@ -2571,7 +2590,7 @@ namespace eval Dwarf { string_ptr: _op .ascii [_quote $dirname] } - _op_offset [expr $_line_is_64 ? 8 : 4] $string_ptr + _op_offset [expr {$_line_is_64 ? 8 : 4}] $string_ptr } } } @@ -2594,7 +2613,7 @@ namespace eval Dwarf { _op .uleb128 0x0f \ "file_name_entry_format (form: DW_FORM_udata)" - set nr_files [expr [llength $_line_file_names] / 2] + set nr_files [expr {[llength $_line_file_names] / 2}] _op .byte $nr_files "file_names_count" foreach { filename diridx } $_line_file_names { @@ -2608,7 +2627,7 @@ namespace eval Dwarf { string_ptr: _op .ascii [_quote $filename] } - _op_offset [expr $_line_is_64 ? 8 : 4] $string_ptr + _op_offset [expr {$_line_is_64 ? 8 : 4}] $string_ptr } } _op .uleb128 $diridx @@ -2746,21 +2765,21 @@ namespace eval Dwarf { variable _line _op .byte 3 DW_LNS_advance_line _op .sleb128 ${offset} - set _line [expr $_line + $offset] + set _line [expr {$_line + $offset}] } # A pseudo line number program instruction, that can be used instead # of DW_LNS_advance_line. Rather than writing: - # {DW_LNS_advance_line [expr $line1 - 1]} - # {DW_LNS_advance_line [expr $line2 - $line1]} - # {DW_LNS_advance_line [expr $line3 - $line2]} + # {DW_LNS_advance_line [expr {$line1 - 1}]} + # {DW_LNS_advance_line [expr {$line2 - $line1}]} + # {DW_LNS_advance_line [expr {$line3 - $line2}]} # we can just write: # {line $line1} # {line $line2} # {line $line3} proc line {line} { variable _line - set offset [expr $line - $_line] + set offset [expr {$line - $_line}] DW_LNS_advance_line $offset } @@ -2778,7 +2797,8 @@ namespace eval Dwarf { } } - uplevel $body + variable _level + uplevel $_level $body rename include_dir "" rename file_name "" @@ -2922,12 +2942,12 @@ namespace eval Dwarf { incr offset # Padding. - set tuple_size [expr 2 * $_addr_size + $_seg_size] + set tuple_size [expr {2 * $_addr_size + $_seg_size}] if {$tuple_size == 0} { set tuple_size 1 } while { 1 } { - if { [expr $offset % $tuple_size] == 0 } { + if { $offset % $tuple_size == 0 } { break } _op .byte 0 "Pad to $tuple_size byte boundary" @@ -2935,7 +2955,8 @@ namespace eval Dwarf { } # Range tuples. - uplevel $body + variable _level + uplevel $_level $body # Terminator tuple. set comment "Terminator" @@ -3031,8 +3052,9 @@ namespace eval Dwarf { # Introduce command 'entry'. with_override Dwarf::entry Dwarf::_loc_entry { + variable _level # Emit entries. - uplevel $body + uplevel $_level $body } # Determine how to emit addresses. @@ -3068,9 +3090,27 @@ namespace eval Dwarf { } } + # Emit a .debug_sup section with the given file name and build-id. + # The buildid should be represented as a hexadecimal string, like + # "ffeeddcc". + proc debug_sup {is_sup filename buildid} { + _defer_output .debug_sup { + # The version. + _op .2byte 0x5 + # Supplementary marker. + _op .byte $is_sup + _op .ascii [_quote $filename] + set len [expr {[string length $buildid] / 2}] + _op .uleb128 $len + foreach {a b} [split $buildid {}] { + _op .byte 0x$a$b + } + } + } + proc _note {type name hexdata} { - set namelen [expr [string length $name] + 1] - set datalen [expr [string length $hexdata] / 2] + set namelen [expr {[string length $name] + 1}] + set datalen [expr {[string length $hexdata] / 2}] # Name size. _op .4byte $namelen @@ -3110,13 +3150,16 @@ namespace eval Dwarf { # Emit a dummy CU. proc dummy_cu {} { - # Generate a CU with default options and empty body. - cu {label dummy_cu} { - compile_unit {} - } + variable _level + uplevel $_level { + # Generate a CU with default options and empty body. + cu {label dummy_cu} { + compile_unit {} + } - # Generate an .debug_aranges entry for the dummy CU. - aranges {} dummy_cu { + # Generate an .debug_aranges entry for the dummy CU. + aranges {} dummy_cu { + } } } @@ -3201,7 +3244,8 @@ namespace eval Dwarf { with_override Dwarf::cu Dwarf::_debug_names_cu { with_override Dwarf::tu Dwarf::_debug_names_tu { with_override Dwarf::name Dwarf::_debug_names_name { - uplevel $body + variable _level + uplevel $_level $body }}} # Header - CU / TU / foreign TU count. @@ -3367,6 +3411,58 @@ namespace eval Dwarf { debug_names_end: } + # Add the strings in ARGS to the .debug_str section, and create a + # .debug_str_offsets section pointing to those strings. + # Current options are: + # dwo 0|1 - boolean indicating if the sections have the dwo suffix. + # default = 0 (no .dwo suffix) + # base_offset label + # - generate label, to be used in DW_AT_str_offsets_base. + # default = "" (don't generate a label). + proc debug_str_offsets { options args } { + parse_options { + { dwo 0 } + { base_offset "" } + } + + if { $dwo } { + _section .debug_str.dwo + } else { + _section .debug_str + } + + set num 0 + foreach arg $args { + set str_label [_compute_label "str_${num}"] + define_label $str_label + _op .asciz \"$arg\" ".debug_str_offsets string $num" + incr num + } + + declare_labels debug_str_offsets_start debug_str_offsets_end + set initial_length "$debug_str_offsets_end - $debug_str_offsets_start" + + if { $dwo } { + _section .debug_str_offsets.dwo + } else { + _section .debug_str_offsets + } + _op .4byte $initial_length "Initial_length" + debug_str_offsets_start: + _op .2byte 0x5 "version" + _op .2byte 0x0 "padding" + if { $base_offset != "" } { + $base_offset: + } + set num 0 + foreach arg $args { + set str_label [_compute_label "str_${num}"] + _op .4byte $str_label "string $num" + incr num + } + debug_str_offsets_end: + } + # The top-level interface to the DWARF assembler. # OPTIONS is a list with an even number of elements containing # option-name and option-value pairs. @@ -3411,11 +3507,14 @@ namespace eval Dwarf { variable _line_header_end_label variable _debug_ranges_64_bit variable _debug_addr_index + variable _level if { [llength $options] == 1 } { set options [list filename [lindex $options 0]] } + set _level "#[info level]" + parse_options { { filename "" } { file_id "" } @@ -3447,13 +3546,14 @@ namespace eval Dwarf { # Dummy CU at the start to ensure that the first CU in $body is not # the first in .debug_info. if { $add_dummy_cus } { - dummy_cu + uplevel $_level dummy_cu } with_shared_gdb { # Not "uplevel" here, because we want to evaluate in this # namespace. This is somewhat bad because it means we can't # readily refer to outer variables. + # tclint-disable-next-line command-args eval $body } diff --git a/gdb/testsuite/lib/fortran.exp b/gdb/testsuite/lib/fortran.exp index 6f2bbd8..7572388 100644 --- a/gdb/testsuite/lib/fortran.exp +++ b/gdb/testsuite/lib/fortran.exp @@ -19,11 +19,12 @@ # The result is 1 (true) for success, 0 (false) for failure. proc set_lang_fortran {} { - if [gdb_test_no_output "set language fortran"] { + if {[gdb_test_no_output "set language fortran"]} { return 0 } - if [gdb_test "show language" ".* source language is \"fortran\"." \ - "set language to \"fortran\""] { + if {[gdb_test "show language" \ + [string_to_regexp {The current source language is "fortran".}] \ + {set language to "fortran"}]} { return 0 } return 1 diff --git a/gdb/testsuite/lib/future.exp b/gdb/testsuite/lib/future.exp index 161c31c..3064c3e 100644 --- a/gdb/testsuite/lib/future.exp +++ b/gdb/testsuite/lib/future.exp @@ -27,11 +27,11 @@ proc gdb_find_gnatmake {} { set root "$tool_root_dir/gcc" set GM "" - if ![is_remote host] { + if {![is_remote host]} { set file [lookfor_file $root gnatmake] if { $file != "" } { set GM "$file -I$root/ada/rts --GCC=$root/xgcc --GNATBIND=$root/gnatbind --GNATLINK=$root/gnatlink -cargs -B$root -largs --GCC=$root/xgcc -margs"; - } + } } if {$GM == ""} { @@ -39,7 +39,7 @@ proc gdb_find_gnatmake {} { } return $GM -} +} proc gdb_find_gdc {} { global tool_root_dir @@ -138,7 +138,7 @@ proc gdb_find_hipcc {} { proc gdb_find_ldd {} { global LDD_FOR_TARGET - if [info exists LDD_FOR_TARGET] { + if {[info exists LDD_FOR_TARGET]} { set ldd $LDD_FOR_TARGET } else { set ldd "ldd" @@ -148,7 +148,7 @@ proc gdb_find_ldd {} { proc gdb_find_objcopy {} { global OBJCOPY_FOR_TARGET - if [info exists OBJCOPY_FOR_TARGET] { + if {[info exists OBJCOPY_FOR_TARGET]} { set objcopy $OBJCOPY_FOR_TARGET } else { set objcopy [transform objcopy] @@ -159,7 +159,7 @@ proc gdb_find_objcopy {} { # find target objdump proc gdb_find_objdump {} { global OBJDUMP_FOR_TARGET - if [info exists OBJDUMP_FOR_TARGET] { + if {[info exists OBJDUMP_FOR_TARGET]} { set objdump $OBJDUMP_FOR_TARGET } else { set objdump [transform objdump] @@ -169,7 +169,7 @@ proc gdb_find_objdump {} { proc gdb_find_readelf {} { global READELF_FOR_TARGET - if [info exists READELF_FOR_TARGET] { + if {[info exists READELF_FOR_TARGET]} { set readelf $READELF_FOR_TARGET } else { set readelf [transform readelf] @@ -179,7 +179,7 @@ proc gdb_find_readelf {} { proc gdb_find_eu-unstrip {} { global EU_UNSTRIP_FOR_TARGET - if [info exists EU_UNSTRIP_FOR_TARGET] { + if {[info exists EU_UNSTRIP_FOR_TARGET]} { set eu_unstrip $EU_UNSTRIP_FOR_TARGET } else { set eu_unstrip [transform eu-unstrip] @@ -482,7 +482,7 @@ proc gdb_default_target_compile_1 {source destfile type options} { } if {[isnative]} { # This is a lose. - catch "glob -nocomplain $tool_root_dir/libstdc++/libstdc++.so* $tool_root_dir/libstdc++/libstdc++.sl" tmp + catch {glob -nocomplain $tool_root_dir/libstdc++/libstdc++.so* $tool_root_dir/libstdc++/libstdc++.sl} tmp if { ${tmp} != "" } { if {[regexp ".*solaris2.*" $target_triplet]} { # Solaris 2 @@ -749,19 +749,6 @@ if { [array size use_gdb_compile] != 0 } { rename gdb_default_target_compile "" } - -# Provide 'lreverse' missing in Tcl before 7.5. - -if {[info procs lreverse] == ""} { - proc lreverse { arg } { - set retval {} - while { [llength $retval] < [llength $arg] } { - lappend retval [lindex $arg end-[llength $retval]] - } - return $retval - } -} - # Various ccache versions provide incorrect debug info such as ignoring # different current directory, breaking GDB testsuite. set env(CCACHE_DISABLE) 1 diff --git a/gdb/testsuite/lib/gdb-guile.exp b/gdb/testsuite/lib/gdb-guile.exp index 776dbc6..9205312 100644 --- a/gdb/testsuite/lib/gdb-guile.exp +++ b/gdb/testsuite/lib/gdb-guile.exp @@ -37,7 +37,7 @@ proc gdb_scm_test_silent_cmd { cmd name {report_pass 1} } { -re "Backtrace.*$gdb_prompt $" { fail $name } -re "ERROR.*$gdb_prompt $" { fail $name } -re "Undefined command: .*$gdb_prompt $" { fail $name } - -re "$gdb_prompt $" { if $report_pass { pass $name } } + -re "$gdb_prompt $" { if {$report_pass} { pass $name } } } } @@ -85,7 +85,7 @@ proc gdb_install_guile_module { } { # The result is the same as for runto_main. proc gdb_guile_runto_main { } { - if ![runto_main] { + if {![runto_main]} { return 0 } diff --git a/gdb/testsuite/lib/gdb-python.exp b/gdb/testsuite/lib/gdb-python.exp index b4eb40d..e026c1b 100644 --- a/gdb/testsuite/lib/gdb-python.exp +++ b/gdb/testsuite/lib/gdb-python.exp @@ -77,3 +77,24 @@ proc gdb_py_module_available { name } { return ${available} } + +# Run a memory leak test within the Python script FILENAME. This proc +# checks that the required Python modules are available, sets up the +# syspath so that the helper module can be found (in the same +# directory as FILENAME), then loads FILENAME to run the test. +proc gdb_py_run_memory_leak_test { filename testname } { + if { ![gdb_py_module_available "tracemalloc"] } { + unsupported "$testname (tracemalloc module not available)" + } + + gdb_test_no_output -nopass "python import sys" + gdb_test_no_output -nopass \ + "python sys.path.insert(0, \"[file dirname $filename]\")" \ + "setup sys.path" + + set pyfile [gdb_remote_download host ${filename}] + + # Source the Python script, this runs the test, and either prints + # PASS, or throws an exception. + gdb_test "source ${pyfile}" "^PASS" $testname +} diff --git a/gdb/testsuite/lib/gdb-utils.exp b/gdb/testsuite/lib/gdb-utils.exp index fe2cfca..f4506a1 100644 --- a/gdb/testsuite/lib/gdb-utils.exp +++ b/gdb/testsuite/lib/gdb-utils.exp @@ -20,10 +20,10 @@ proc gdb_init_commands {} { set commands "" - if [target_info exists gdb_init_command] { + if {[target_info exists gdb_init_command]} { lappend commands [target_info gdb_init_command] } - if [target_info exists gdb_init_commands] { + if {[target_info exists gdb_init_commands]} { set commands [concat $commands [target_info gdb_init_commands]] } return $commands @@ -70,6 +70,8 @@ proc style {str style} { set fg 39 set bg 49 set intensity 22 + set italic 23 + set underline 24 set reverse 27 switch -exact -- $style { title { set intensity 1 } @@ -84,7 +86,7 @@ proc style {str style} { line-number { set intensity 2 } none { return $str } } - return "\033\\\[${fg};${bg};${intensity};${reverse}m${str}\033\\\[m" + return "\033\\\[${fg};${bg};${intensity};${italic};${underline};${reverse}m${str}\033\\\[m" } # gdb_get_bp_addr num @@ -163,6 +165,7 @@ proc version_compare { l1 op l2 } { if {$v1 == $v2} { continue } + # tclint-disable-next-line unbraced-expr return [expr $v1 $op $v2] } diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp index c37cc89..ef6a8f8 100644 --- a/gdb/testsuite/lib/gdb.exp +++ b/gdb/testsuite/lib/gdb.exp @@ -15,6 +15,8 @@ # This file was written by Fred Fish. (fnf@cygnus.com) +package require Tcl 8.6.2 + # Generic gdb subroutines that should work for any target. If these # need to be modified for any target, it can be done with a variable # or by passing arguments. @@ -134,7 +136,7 @@ proc load_lib { file } { set known_globals($varname) 1 } - set code [catch "saved_load_lib $file" result] + set code [catch {saved_load_lib $file} result] foreach varname [info globals] { if { ![info exists known_globals($varname)] } { @@ -173,11 +175,11 @@ global GDB_DATA_DIRECTORY # so input/output is done on gdbserver's tty. global inferior_spawn_id -if [info exists TOOL_EXECUTABLE] { +if {[info exists TOOL_EXECUTABLE]} { set GDB $TOOL_EXECUTABLE } -if ![info exists GDB] { - if ![is_remote host] { +if {![info exists GDB]} { + if {![is_remote host]} { set GDB [findfile $base_dir/../../gdb/gdb "$base_dir/../../gdb/gdb" [transform gdb]] } else { set GDB [transform gdb] @@ -186,7 +188,7 @@ if ![info exists GDB] { # If the user specifies GDB on the command line, and doesn't # specify GDB_DATA_DIRECTORY, then assume we're testing an # installed GDB, and let it use its own configured data directory. - if ![info exists GDB_DATA_DIRECTORY] { + if {![info exists GDB_DATA_DIRECTORY]} { set GDB_DATA_DIRECTORY "" } } @@ -195,7 +197,7 @@ verbose "using GDB = $GDB" 2 # The data directory the testing GDB will use. By default, assume # we're testing a non-installed GDB in the build directory. Users may # also explicitly override the -data-directory from the command line. -if ![info exists GDB_DATA_DIRECTORY] { +if {![info exists GDB_DATA_DIRECTORY]} { set GDB_DATA_DIRECTORY [file normalize "[pwd]/../data-directory"] } verbose "using GDB_DATA_DIRECTORY = $GDB_DATA_DIRECTORY" 2 @@ -223,7 +225,7 @@ proc has_gcore_script {} { # - append new flags, not overwrite # - restore the original value when done global GDBFLAGS -if ![info exists GDBFLAGS] { +if {![info exists GDBFLAGS]} { set GDBFLAGS "" } verbose "using GDBFLAGS = $GDBFLAGS" 2 @@ -248,7 +250,7 @@ proc append_gdb_data_directory_option {cmdline} { # `-data-directory' points to the data directory, usually in the build # directory. global INTERNAL_GDBFLAGS -if ![info exists INTERNAL_GDBFLAGS] { +if {![info exists INTERNAL_GDBFLAGS]} { set INTERNAL_GDBFLAGS \ [join [list \ "-nw" \ @@ -269,6 +271,13 @@ if ![info exists INTERNAL_GDBFLAGS] { } set INTERNAL_GDBFLAGS [append_gdb_data_directory_option $INTERNAL_GDBFLAGS] + + # Handle the case that "interactive-mode auto" reports off. + append INTERNAL_GDBFLAGS { -iex "set interactive-mode on"} + + if { [ishost "*-*-mingw*"] } { + append INTERNAL_GDBFLAGS { --binary-output} + } } # The variable gdb_prompt is a regexp which matches the gdb prompt. @@ -280,27 +289,30 @@ if {![info exists gdb_prompt]} { set gdb_prompt "\\(gdb\\)" } -# A regexp that matches the pagination prompt. -set pagination_prompt \ +# The pagination prompt. +set pagination_prompt_str \ "--Type <RET> for more, q to quit, c to continue without paging--" -# The variable fullname_syntax_POSIX is a regexp which matches a POSIX -# absolute path ie. /foo/ +# A regexp that matches the pagination prompt. +set pagination_prompt [string_to_regexp $pagination_prompt_str] + +# The variable fullname_syntax_POSIX is a regexp which matches a POSIX +# absolute path ie. "/foo/". set fullname_syntax_POSIX {/[^\n]*/} -# The variable fullname_syntax_UNC is a regexp which matches a Windows -# UNC path ie. \\D\foo\ +# The variable fullname_syntax_UNC is a regexp which matches a Windows +# UNC path ie. "\\D\foo\". set fullname_syntax_UNC {\\\\[^\\]+\\[^\n]+\\} -# The variable fullname_syntax_DOS_CASE is a regexp which matches a +# The variable fullname_syntax_DOS_CASE is a regexp which matches a # particular DOS case that GDB most likely will output -# ie. \foo\, but don't match \\.*\ +# ie. "\foo\", but don't match "\\.*\". set fullname_syntax_DOS_CASE {\\[^\\][^\n]*\\} # The variable fullname_syntax_DOS is a regexp which matches a DOS path -# ie. a:\foo\ && a:foo\ +# ie. "a:\foo\" && "a:foo\". set fullname_syntax_DOS {[a-zA-Z]:[^\n]*\\} # The variable fullname_syntax is a regexp which matches what GDB considers -# an absolute path. It is currently debatable if the Windows style paths -# d:foo and \abc should be considered valid as an absolute path. -# Also, the purpse of this regexp is not to recognize a well formed +# an absolute path. It is currently debatable if the Windows style paths +# "d:foo" and "\abc" should be considered valid as an absolute path. +# Also, the purpose of this regexp is not to recognize a well formed # absolute path, but to say with certainty that a path is absolute. set fullname_syntax "($fullname_syntax_POSIX|$fullname_syntax_UNC|$fullname_syntax_DOS_CASE|$fullname_syntax_DOS)" @@ -308,7 +320,7 @@ set fullname_syntax "($fullname_syntax_POSIX|$fullname_syntax_UNC|$fullname_synt global EXEEXT global env -if ![info exists env(EXEEXT)] { +if {![info exists env(EXEEXT)]} { set EXEEXT "" } else { set EXEEXT $env(EXEEXT) @@ -346,14 +358,14 @@ proc default_gdb_version {} { global inotify_pid if {[info exists inotify_pid]} { - eval exec kill $inotify_pid + exec kill $inotify_pid } set output [remote_exec host "$GDB $INTERNAL_GDBFLAGS --version"] set tmp [lindex $output 1] set version "" regexp " \[0-9\]\[^ \t\n\r\]+" "$tmp" version - if ![is_remote host] { + if {![is_remote host]} { clone_output "[which $GDB] version $version $INTERNAL_GDBFLAGS $GDBFLAGS\n" } else { clone_output "$GDB on remote host version $version $INTERNAL_GDBFLAGS $GDBFLAGS\n" @@ -394,7 +406,7 @@ proc gdb_unload { {msg "file"} } { # Many of the tests depend on setting breakpoints at various places and # running until that breakpoint is reached. At times, we want to start -# with a clean-slate with respect to breakpoints, so this utility proc +# with a clean-slate with respect to breakpoints, so this utility proc # lets us do this without duplicating this code everywhere. # @@ -453,7 +465,7 @@ proc target_can_use_run_cmd { {target_description ""} } { error "invalid argument: $target_description" } - if [target_info exists use_gdb_stub] { + if {[target_info exists use_gdb_stub]} { # In this case, when we connect, the inferior is already # running. return 0 @@ -497,8 +509,8 @@ proc gdb_run_cmd { {inferior_args {}} } { } } - if $use_gdb_stub { - if [target_info exists gdb,do_reload_on_run] { + if {$use_gdb_stub} { + if {[target_info exists gdb,do_reload_on_run]} { if { [gdb_reload $inferior_args] != 0 } { return -1 } @@ -510,7 +522,7 @@ proc gdb_run_cmd { {inferior_args {}} } { return 0 } - if [target_info exists gdb,start_symbol] { + if {[target_info exists gdb,start_symbol]} { set start [target_info gdb,start_symbol] } else { set start "start" @@ -521,11 +533,11 @@ proc gdb_run_cmd { {inferior_args {}} } { # Cap (re)start attempts at three to ensure that this loop # always eventually fails. Don't worry about trying to be # clever and not send a command when it has failed. - if [expr $start_attempt > 3] { + if {$start_attempt > 3} { perror "Jump to start() failed (retry count exceeded)" return -1 } - set start_attempt [expr $start_attempt + 1] + set start_attempt [expr {$start_attempt + 1}] gdb_expect 30 { -re "Continuing at \[^\r\n\]*\[\r\n\]" { set start_attempt 0 @@ -559,7 +571,7 @@ proc gdb_run_cmd { {inferior_args {}} } { return 0 } - if [target_info exists gdb,do_reload_on_run] { + if {[target_info exists gdb,do_reload_on_run]} { if { [gdb_reload $inferior_args] != 0 } { return -1 } @@ -608,7 +620,7 @@ proc gdb_start_cmd { {inferior_args {}} } { } } - if $use_gdb_stub { + if {$use_gdb_stub} { return -1 } @@ -651,7 +663,7 @@ proc gdb_starti_cmd { {inferior_args {}} } { } } - if $use_gdb_stub { + if {$use_gdb_stub} { return -1 } @@ -726,7 +738,7 @@ proc gdb_breakpoint { linespec args } { return 0 } } - -re "Make breakpoint pending.*y or \\\[n\\\]. $" { + -re "Make breakpoint pending.*y or \\\[n\\\]. $" { send_gdb "$pending_response\n" exp_continue } @@ -741,7 +753,7 @@ proc gdb_breakpoint { linespec args } { pass $test_name } return 1 -} +} # Set breakpoint at function and run gdb until it breaks there. # Since this is the only breakpoint that will be set, if it stops @@ -787,7 +799,7 @@ proc runto { linespec args } { } gdb_run_cmd - + # the "at foo.c:36" output we get with -g. # the "in func" output we get without -g. gdb_expect { @@ -816,19 +828,19 @@ proc runto { linespec args } { gdb_internal_error_resync return 0 } - -re "$gdb_prompt $" { + -re "$gdb_prompt $" { if { $print_fail } { fail $test_name } return 0 } - eof { + eof { if { $print_fail } { fail "$test_name (eof)" } return 0 } - timeout { + timeout { if { $print_fail } { fail "$test_name (timeout)" } @@ -1026,7 +1038,10 @@ proc command_to_message { command } { # should not be anchored at the end of the buffer. This means that the # pattern can match even if there is stuff output after the prompt. Does not # have any effect if -prompt is specified. -# -lbl specifies that line-by-line matching will be used. +# -lbl specifies that line-by-line matching will be used. This means +# that lines from GDB not matched by any pattern will be consumed from +# the output buffer. This helps avoid buffer overflows and timeouts +# when testing verbose commands. # EXPECT_ARGUMENTS will be fed to expect in addition to the standard # patterns. Pattern elements will be evaluated in the caller's # context; action elements will be executed in the caller's context. @@ -1037,7 +1052,7 @@ proc command_to_message { command } { # 1 if the test failed, according to a built-in failure pattern # 0 if only user-supplied patterns matched # -1 if there was an internal error. -# +# # You can use this function thus: # # gdb_test_multiple "print foo" "test foo" { @@ -1124,6 +1139,7 @@ proc gdb_test_multiple { command message args } { global any_spawn_id set line_by_line 0 + set lbl_anchor_re "" set prompt_regexp "" set prompt_anchor 1 for {set i 0} {$i < [llength $args]} {incr i} { @@ -1133,6 +1149,7 @@ proc gdb_test_multiple { command message args } { set prompt_regexp [lindex $args $i] } elseif { $arg == "-lbl" } { set line_by_line 1 + set lbl_anchor_re "^" } elseif { $arg == "-no-prompt-anchor" } { set prompt_anchor 0 } else { @@ -1140,7 +1157,7 @@ proc gdb_test_multiple { command message args } { break } } - if { [expr $i + 1] < [llength $args] } { + if {$i + 1 < [llength $args]} { error "Too many arguments to gdb_test_multiple" } elseif { ![info exists user_code] } { error "Too few arguments to gdb_test_multiple" @@ -1152,15 +1169,15 @@ proc gdb_test_multiple { command message args } { set message [command_to_message $command] } - if [string match "*\[\r\n\]" $command] { + if {[string match "*\[\r\n\]" $command]} { error "Invalid trailing newline in \"$command\" command" } - if [string match "*\[\003\004\]" $command] { + if {[string match "*\[\003\004\]" $command]} { error "Invalid trailing control code in \"$command\" command" } - if [string match "*\[\r\n\]*" $message] { + if {[string match "*\[\r\n\]*" $message]} { error "Invalid newline in \"$message\" test" } @@ -1285,7 +1302,7 @@ proc gdb_test_multiple { command message args } { while { "$string" != "" } { set foo [string first "\n" "$string"] set len [string length "$string"] - if { $foo < [expr $len - 1] } { + if {$foo < $len - 1} { set str [string range "$string" 0 $foo] if { [send_gdb "$str"] != "" } { verbose -log "Couldn't send $command to GDB." @@ -1301,7 +1318,7 @@ proc gdb_test_multiple { command message args } { -notransfer -re "$multi_line_re$" { verbose "partial: match" 3 } timeout { verbose "partial: timeout" 3 } } - set string [string range "$string" [expr $foo + 1] end] + set string [string range "$string" [expr {$foo + 1}] end] set multi_line_re "$multi_line_re.*\[\r\n\] *>" } else { break @@ -1391,7 +1408,7 @@ proc gdb_test_multiple { command message args } { fail "$errmsg" set result -1 } - -re "\r\n$prompt_regexp" { + -re "${lbl_anchor_re}\r\n$prompt_regexp" { if {![string match "" $message]} { fail "$message" } @@ -1586,8 +1603,8 @@ proc gdb_test { args } { set message [command_to_message $command] } - set prompt [fill_in_default_prompt $prompt [expr !${no-prompt-anchor}]] - set nl [expr ${nonl} ? {""} : {"\r\n"}] + set prompt [fill_in_default_prompt $prompt [expr {!${no-prompt-anchor}}]] + set nl [expr {${nonl} ? "" : "\r\n"}] set saw_question 0 @@ -1663,76 +1680,9 @@ proc python_version_at_least { major minor } { # Return 1 if tcl version used is at least MAJOR.MINOR.PATCHLEVEL. proc tcl_version_at_least { major minor {patchlevel 0} } { - global tcl_patchLevel - regexp {^([0-9]+)\.([0-9]+)\.([0-9]+)$} \ - $tcl_patchLevel dummy \ - tcl_version_major tcl_version_minor tcl_version_patchlevel - return \ - [version_compare \ - [list \ - $major \ - $minor \ - $patchlevel] \ - <= \ - [list \ - $tcl_version_major \ - $tcl_version_minor \ - $tcl_version_patchlevel]] -} - -if { [tcl_version_at_least 8 5] == 0 } { - # lrepeat was added in tcl 8.5. Only add if missing. - proc lrepeat { n element } { - if { [string is integer -strict $n] == 0 } { - error "expected integer but got \"$n\"" - } - if { $n < 0 } { - error "bad count \"$n\": must be integer >= 0" - } - set res [list] - for {set i 0} {$i < $n} {incr i} { - lappend res $element - } - return $res - } -} - -if { [tcl_version_at_least 8 6] == 0 } { - # lmap was added in tcl 8.6. Only add if missing. - - # Note that we only implement the simple variant for now. - proc lmap { varname list body } { - set res {} - foreach val $list { - uplevel 1 "set $varname $val" - lappend res [uplevel 1 $body] - } - - return $res - } - - # ::tcl_platform(pathSeparator) was added in 8.6. - switch $::tcl_platform(platform) { - windows { - set ::tcl_platform(pathSeparator) ; - } - default { - set ::tcl_platform(pathSeparator) : - } - } -} - -if { [tcl_version_at_least 8 6 2] == 0 } { - # string cat was added in tcl 8.6.2. Only add if missing. - - rename string tcl_proc_string - - proc string { what args } { - if { $what == "cat" } { - return [join $args ""] - } - return [tcl_proc_string $what {*}$args] - } + set current_version [package require Tcl] + set min_version "$major.$minor.$patchlevel" + return [expr {[package vcompare $current_version $min_version] >= 0}] } # gdb_test_no_output [-prompt PROMPT_REGEXP] [-nopass] COMMAND [MESSAGE] @@ -1758,7 +1708,7 @@ proc gdb_test_no_output { args } { set args [lassign $args command message] check_no_args_left - set prompt [fill_in_default_prompt $prompt [expr !${no-prompt-anchor}]] + set prompt [fill_in_default_prompt $prompt [expr {!${no-prompt-anchor}}]] set command_regex [string_to_regexp $command] return [gdb_test_multiple $command $message -prompt $prompt { @@ -2010,7 +1960,7 @@ proc gdb_test_exact { args } { # string pattern. set pattern [lindex $args 1] - if [string match $pattern ""] { + if {[string match $pattern ""]} { set pattern [string_to_regexp [lindex $args 0]] } else { set pattern [string_to_regexp [lindex $args 1]] @@ -2194,7 +2144,7 @@ proc gdb_test_debug_expr { cmd output {testname "" }} { proc gdb_print_expr_at_depths {exp outputs} { for { set depth 0 } { $depth <= [llength $outputs] } { incr depth } { if { $depth == [llength $outputs] } { - set expected_result [lindex $outputs [expr [llength $outputs] - 1]] + set expected_result [lindex $outputs [expr {[llength $outputs] - 1}]] set depth_string "unlimited" } else { set expected_result [lindex $outputs $depth] @@ -2237,10 +2187,213 @@ proc gdb_assert { condition {message ""} } { return $res } +# Comparison command for "lsort -command". Sorts two strings by +# descending file name length. + +proc compare_length_desc {a b} { + expr {[string length $b] - [string length $a]} +} + +# Fill in and return the global cache for Windows <=> Unix mount point +# mappings, for Windows. +# +# Calling external processes on MSYS2/Cygwin is expensive so instead +# of calling "cygpath -ua $FILENAME" or "cygpath -ma $FILENAME" for +# every file name, we extract the Windows and Unix file names of each +# mount point using the 'mount' command output, and cache the +# mappings, for both directions. + +gdb_caching_proc get_mount_point_map {} { + array set win_to_unix {} + array set unix_to_win {} + + # The 'mount' command provides all mappings. The general format + # is: 'WindowsFileName on UnixFileName type ...' + # + # For example: + # 'C:/msys64 on / type ntfs (binary,auto)' + # 'C: on /c type ntfs (binary,posix=0,user,noumount,auto)' + set mount_output [exec mount] + + foreach line [split $mount_output \n] { + if {[regexp {^(.+) on (.+) type } $line -> win_filename unix_filename]} { + set win_to_unix($win_filename) $unix_filename + set unix_to_win($unix_filename) $win_filename + } + } + + # Sort each mapping's keys by descending file name length, + # otherwise we wouldn't be able to look for '/foo' in '/' (for + # example). + + set sorted_win {} + foreach k [lsort -command compare_length_desc [array names win_to_unix]] { + lappend sorted_win $k $win_to_unix($k) + } + + set sorted_unix {} + foreach k [lsort -command compare_length_desc [array names unix_to_win]] { + lappend sorted_unix $k $unix_to_win($k) + } + + # Return both sorted lists: {win => unix} {unix => win} + return [list $sorted_win $sorted_unix] +} + +# Normalize backward slashes to forward slashes. + +proc normalize_slashes {filename} { + return [string map {\\ /} $filename] +} + +# Sanitize a host file name, without making it absolute or resolving +# symlinks. On native Windows, this normalizes slashes to forward +# slashes, and makes sure that if the file name starts with a drive +# letter, it is upper case. On other systems, it just returns the +# file name unmodified. + +proc host_file_sanitize {filename} { + if {[ishost *-*-mingw*]} { + set filename [normalize_slashes $filename] + + # If the file name starts with a drive letter, uppercase it. + if {[regexp {^([a-zA-Z]):(/.*)?} $filename -> drive rest]} { + set filename "[string toupper $drive]:$rest" + } + } + + return $filename +} + +# Normalize a file name for the build machine. If running native +# Windows GDB, this converts a Windows file name to the corresponding +# Unix filename, per the mount table. For example, this replaces +# 'c:/foo' with '/c/foo' (on MSYS2) or '/cygdrive/c/foo' (on Cygwin). +# On other systems, it just wraps "file normalize". + +proc build_file_normalize {filename} { + if {[ishost *-*-mingw*]} { + set filename [host_file_sanitize $filename] + + # Handle Windows => Unix mount point conversion. We assume + # there are no symlinks to resolve, which is a reasonable + # assumption for native Windows testing. + + # Get Windows => Unix map. + lassign [get_mount_point_map] win_to_unix _ + + foreach {win_filename unix_filename} $win_to_unix { + if {[string equal -length [string length $win_filename] \ + $win_filename $filename]} { + set rest [string range $filename \ + [string length $win_filename] end] + return "${unix_filename}$rest" + } + } + } + + return [file normalize $filename] +} + +# Normalize a file name for the host machine and native Windows GDB. +# This converts a Unix file name to a Windows filename, +# per the mount table. E.g., '/c/foo' (on MSYS2) or '/cygdrive/c/foo' +# (on Cygwin) is converted to 'c:/foo'. + +proc host_file_normalize_mingw {filename unix_to_win} { + set filename [host_file_sanitize $filename] + + # If the file name already starts with a drive letter (e.g., + # C:/foo), we're done. Don't let it fallthrough to "file + # normalize", which would misinterpret it as a relative file + # name. + if {[regexp {^[A-Z]:/} $filename]} { + return $filename + } + + # Collapse all repeated forward slashes. + set filename [regsub -all {//+} $filename {/}] + + # Strip trailing slash, except for root. + if {$filename ne "/" && [string match */ $filename]} { + set filename [string range $filename 0 end-1] + } + + foreach {unix_filename win_filename} $unix_to_win { + set mount_len [string length $unix_filename] + if {[string equal -length $mount_len $unix_filename $filename]} { + if {$unix_filename eq "/"} { + if {$filename eq "/"} { + return "$win_filename" + } else { + return "$win_filename$filename" + } + } elseif {[string length $filename] == $mount_len} { + # Like "cygpath -ma" if the file name resolves to a + # drive letter, append a slash, to make it unambiguous + # that we resolved to the root of the drive and not + # the drive's current directory. + if {[string match {[A-Za-z]:} $win_filename]} { + return "$win_filename/" + } else { + return "$win_filename" + } + } elseif {[string index $filename $mount_len] eq "/"} { + set rest [string range $filename $mount_len end] + return "$win_filename$rest" + } + } + } + + return [file normalize $filename] +} + +# Normalize a file name for the host machine. If running native +# Windows GDB, this converts a Unix file name to a Windows filename, +# per the mount table. E.g., '/c/foo' (on MSYS2) or '/cygdrive/c/foo' +# (on Cygwin) is converted to 'c:/foo'. + +proc host_file_normalize {filename} { + if {[ishost *-*-mingw*]} { + # Get Unix => Windows map. + lassign [get_mount_point_map] _ unix_to_win + return [host_file_normalize_mingw $filename $unix_to_win] + } + + return [file normalize $filename] +} + +# Wrapper around "file join" that handles host-specific details. +# +# For Cygwin/MSYS2's Tcl, file names that start with a drive letter +# are not considered absolute file names, thus 'file join "c:/" "d:/"' +# returns "c:/d:". This procedure thus detects absolute Windows-style +# file names, and treats them as absolute, bypassing "file join". + +proc host_file_join {args} { + if {[isbuild *-*-mingw*]} { + set result "" + foreach filename $args { + set filename [host_file_sanitize $filename] + + # If the file name starts with drive letter and colon + # (e.g., "C:/"), treat it as absolute. + if {[regexp {^[A-Z]:/} $filename]} { + set result $filename + } else { + set result [file join $result $filename] + } + } + return $result + } else { + return [file join {*}$args] + } +} + proc gdb_reinitialize_dir { subdir } { global gdb_prompt - if [is_remote host] { + if {[is_remote host]} { return "" } send_gdb "dir\n" @@ -2251,7 +2404,8 @@ proc gdb_reinitialize_dir { subdir } { } gdb_expect 60 { -re "Source directories searched.*$gdb_prompt $" { - send_gdb "dir $subdir\n" + set dir [host_file_normalize $subdir] + send_gdb "dir $dir\n" gdb_expect 60 { -re "Source directories searched.*$gdb_prompt $" { verbose "Dir set to $subdir" @@ -2281,7 +2435,7 @@ proc default_gdb_exit {} { global gdb_spawn_id inferior_spawn_id global inotify_log_file - if ![info exists gdb_spawn_id] { + if {![info exists gdb_spawn_id]} { return } @@ -2301,7 +2455,8 @@ proc default_gdb_exit {} { } } - if { [is_remote host] && [board_info host exists fileid] } { + if { ([is_remote host] && [board_info host exists fileid]) + || [istarget *-*-mingw*] } { send_gdb "quit\n" gdb_expect 10 { -re "y or n" { @@ -2313,8 +2468,10 @@ proc default_gdb_exit {} { } } - if ![is_remote host] { - remote_close host + if {![is_remote host]} { + if {[catch { remote_close host } message]} { + warning "closing gdb failed with: $message" + } } unset gdb_spawn_id unset ::gdb_tty_name @@ -2364,7 +2521,7 @@ proc gdb_file_cmd { arg {kill_flag 1} } { global gdb_file_cmd_debug_info gdb_file_cmd_msg set gdb_file_cmd_debug_info "fail" - if [is_remote host] { + if {[is_remote host]} { set arg [remote_download host $arg] if { $arg == "" } { perror "download failed" @@ -2503,11 +2660,11 @@ proc default_gdb_spawn { } { verbose "Spawning $GDB $INTERNAL_GDBFLAGS $GDBFLAGS" gdb_write_cmd_file "$GDB $INTERNAL_GDBFLAGS $GDBFLAGS" - if [info exists gdb_spawn_id] { + if {[info exists gdb_spawn_id]} { return 0 } - if ![is_remote host] { + if {![is_remote host]} { if {[which $GDB] == 0} { perror "$GDB does not exist." exit 1 @@ -2533,7 +2690,7 @@ proc default_gdb_start { } { global gdb_spawn_id global inferior_spawn_id - if [info exists gdb_spawn_id] { + if {[info exists gdb_spawn_id]} { return 0 } @@ -2577,6 +2734,17 @@ proc default_gdb_start { } { # Output with -q, and bracketed paste mode enabled, see above. verbose "GDB initialized." } + -re "^\033\\\[6n$gdb_prompt $" { + # With MSYS2 and TERM={xterm,ansi}, I get: + # + # builtin_spawn gdb -q ... + # ^[[6n(gdb) + # + # We set TERM to dumb by default to avoid this, but some + # test-cases set TERM to xterm or ansi, in which case we get this + # output. + verbose "GDB initialized." + } -re "$gdb_prompt $" { perror "GDB never initialized." unset gdb_spawn_id @@ -2599,7 +2767,7 @@ proc default_gdb_start { } { send_gdb "set height 0\n" gdb_expect 10 { - -re "$gdb_prompt $" { + -re "$gdb_prompt $" { verbose "Setting height to 0." 2 } timeout { @@ -2823,11 +2991,6 @@ gdb_caching_proc allow_dap_tests {} { return 0 } - # ton.tcl uses "string is entier", supported starting tcl 8.6. - if { ![tcl_version_at_least 8 6] } { - return 0 - } - # With set auto-connect-native-target off, we run into: # +++ run # Traceback (most recent call last): @@ -2959,6 +3122,10 @@ gdb_caching_proc allow_dlmopen_tests {} { # Return 1 if we should allow TUI-related tests. gdb_caching_proc allow_tui_tests {} { + if { [istarget *-*-mingw*] } { + # Avoid "Cannot enable the TUI when output is not a terminal". + return 0 + } set output [remote_exec host $::GDB "$::INTERNAL_GDBFLAGS --configuration"] return [expr {[string first "--enable-tui" $output] != -1}] } @@ -3075,6 +3242,7 @@ proc foreach_with_prefix {var list body} { # within 'with_test_prefix "$proc_name" { ... }'. proc proc_with_prefix {name arguments body} { # Define the advertised proc. + # tclint-disable-next-line command-args proc $name $arguments [list with_test_prefix $name $body] } @@ -3137,8 +3305,8 @@ proc save_vars { vars body } { # name may be a not-yet-interpolated string like env($foo) set var [uplevel 1 list $var] - if [uplevel 1 [list info exists $var]] { - if [uplevel 1 [list array exists $var]] { + if {[uplevel 1 [list info exists $var]]} { + if {[uplevel 1 [list array exists $var]]} { set saved_arrays($var) [uplevel 1 [list array get $var]] } else { set saved_scalars($var) [uplevel 1 [list set $var]] @@ -3310,14 +3478,14 @@ proc with_gdb_cwd { dir body } { } verbose -log "Switching to directory $dir (saved CWD: $saved_dir)." - if ![gdb_cd $dir] { + if {![gdb_cd $dir]} { return } set code [catch {uplevel 1 $body} result] verbose -log "Switching back to $saved_dir." - if ![gdb_cd $saved_dir] { + if {![gdb_cd $saved_dir]} { return } @@ -3495,7 +3663,7 @@ proc clear_gdb_spawn_id {} { proc with_spawn_id { spawn_id body } { global gdb_spawn_id - if [info exists gdb_spawn_id] { + if {[info exists gdb_spawn_id]} { set saved_spawn_id $gdb_spawn_id } @@ -3503,7 +3671,7 @@ proc with_spawn_id { spawn_id body } { set code [catch {uplevel 1 $body} result] - if [info exists saved_spawn_id] { + if {[info exists saved_spawn_id]} { switch_gdb_spawn_id $saved_spawn_id } else { clear_gdb_spawn_id @@ -3541,7 +3709,7 @@ proc get_largest_timeout {} { upvar 2 timeout timeout set tmt 0 - if [info exists timeout] { + if {[info exists timeout]} { set tmt $timeout } if { [info exists gtimeout] && $gtimeout > $tmt } { @@ -3567,7 +3735,7 @@ proc with_timeout_factor { factor body } { set savedtimeout $timeout - set timeout [expr [get_largest_timeout] * $factor] + set timeout [expr {[get_largest_timeout] * $factor}] set code [catch {uplevel 1 $body} result] set timeout $savedtimeout @@ -3729,7 +3897,7 @@ proc can_single_step_to_signal_handler {} { proc supports_process_record {} { - if [target_info exists gdb,use_precord] { + if {[target_info exists gdb,use_precord]} { return [target_info gdb,use_precord] } @@ -3738,7 +3906,8 @@ proc supports_process_record {} { || [istarget "aarch64*-*-linux*"] || [istarget "loongarch*-*-linux*"] || [istarget "powerpc*-*-linux*"] - || [istarget "s390*-*-linux*"] } { + || [istarget "s390*-*-linux*"] + || [istarget "riscv*-*-*"] } { return 1 } @@ -3749,7 +3918,7 @@ proc supports_process_record {} { proc supports_reverse {} { - if [target_info exists gdb,can_reverse] { + if {[target_info exists gdb,can_reverse]} { return [target_info gdb,can_reverse] } @@ -3758,7 +3927,8 @@ proc supports_reverse {} { || [istarget "aarch64*-*-linux*"] || [istarget "loongarch*-*-linux*"] || [istarget "powerpc*-*-linux*"] - || [istarget "s390*-*-linux*"] } { + || [istarget "s390*-*-linux*"] + || [istarget "riscv*-*-*"] } { return 1 } @@ -3918,12 +4088,12 @@ proc is_x86_like_target {} { if {![istarget "x86_64-*-*"] && ![istarget i?86-*]} { return 0 } - return [expr [is_ilp32_target] && ![is_amd64_regs_target]] + return [expr {[is_ilp32_target] && ![is_amd64_regs_target]}] } # Return 1 if this target is an x86_64 with -m64. proc is_x86_64_m64_target {} { - return [expr [istarget x86_64-*-* ] && [is_lp64_target]] + return [expr {[istarget x86_64-*-* ] && [is_lp64_target]}] } # Return 1 if this target is an arm or aarch32 on aarch64. @@ -3956,7 +4126,7 @@ proc is_aarch64_target {} { return 0 } - return [expr ![is_aarch32_target]] + return [expr {![is_aarch32_target]}] } # Return 1 if displaced stepping is supported on target, otherwise, return 0. @@ -4027,7 +4197,7 @@ gdb_caching_proc libc_has_debug_info {} { } } -# Run a test on the target to see if it supports vmx hardware. Return 1 if so, +# Run a test on the target to see if it supports vmx hardware. Return 1 if so, # 0 if it does not. Based on 'check_vmx_hw_available' from the GCC testsuite. gdb_caching_proc allow_altivec_tests {} { @@ -4047,9 +4217,9 @@ gdb_caching_proc allow_altivec_tests {} { } # Make sure we have a compiler that understands altivec. - if [test_compiler_info gcc*] { + if {[test_compiler_info gcc*]} { set compile_flags "additional_flags=-maltivec" - } elseif [test_compiler_info xlc*] { + } elseif {[test_compiler_info xlc*]} { set compile_flags "additional_flags=-qaltivec" } else { verbose "Could not compile with altivec support, returning 0" 2 @@ -4080,11 +4250,11 @@ gdb_caching_proc allow_altivec_tests {} { gdb_run_cmd gdb_expect { -re ".*Illegal instruction.*${gdb_prompt} $" { - verbose -log "\n$me altivec hardware not detected" + verbose -log "\n$me altivec hardware not detected" set allow_vmx_tests 0 } -re ".*$inferior_exited_re normally.*${gdb_prompt} $" { - verbose -log "\n$me: altivec hardware detected" + verbose -log "\n$me: altivec hardware detected" set allow_vmx_tests 1 } default { @@ -4162,9 +4332,9 @@ gdb_caching_proc allow_vsx_tests {} { } # Make sure we have a compiler that understands altivec. - if [test_compiler_info gcc*] { + if {[test_compiler_info gcc*]} { set compile_flags "additional_flags=-mvsx" - } elseif [test_compiler_info xlc*] { + } elseif {[test_compiler_info xlc*]} { set compile_flags "additional_flags=-qasm=gcc" } else { verbose "Could not compile with vsx support, returning 0" 2 @@ -4264,6 +4434,76 @@ gdb_caching_proc allow_tsx_tests {} { return $allow_tsx_tests } +# Run a test on the target to check if it supports x86 shadow stack. Return 1 +# if shadow stack is enabled, 0 otherwise. + +gdb_caching_proc allow_ssp_tests {} { + global srcdir subdir gdb_prompt hex + + set me "allow_ssp_tests" + + if { ![istarget i?86-*-*] && ![istarget x86_64-*-* ] } { + verbose "$me: target known to not support shadow stack." + return 0 + } + + # There is no need to check the actual HW in addition to ptrace support. + # We need both checks and ptrace will tell us about the HW state. + set compile_flags "{additional_flags=-fcf-protection=return}" + set src { int main() { return 0; } } + if {![gdb_simple_compile $me $src executable $compile_flags]} { + return 0 + } + + save_vars { ::env(GLIBC_TUNABLES) } { + + append_environment GLIBC_TUNABLES "glibc.cpu.hwcaps" "SHSTK" + + # No error message, compilation succeeded so now run it via gdb. + gdb_exit + gdb_start + gdb_reinitialize_dir $srcdir/$subdir + gdb_load $obj + if {![runto_main]} { + remote_file build delete $obj + return 0 + } + set shadow_stack_disabled_re "(<unavailable>)" + if {[istarget *-*-linux*]} { + # Starting with v6.6, the Linux kernel supports CET shadow stack. + # Dependent on the target we can see a nullptr or "<unavailable>" + # when shadow stack is supported by HW and the Linux kernel but + # not enabled for the current thread (for example due to a lack + # of compiler or glibc support for -fcf-protection). + set shadow_stack_disabled_re "$shadow_stack_disabled_re|(.*0x0)" + } + + set allow_ssp_tests 0 + gdb_test_multiple "print \$pl3_ssp" "test shadow stack support" { + -re -wrap "(.*$hex)((?!(.*0x0)).)" { + verbose -log "$me: Shadow stack support detected." + set allow_ssp_tests 1 + } + -re -wrap $shadow_stack_disabled_re { + # In case shadow stack is not enabled (for example due to a + # lack of compiler or glibc support for -fcf-protection). + verbose -log "$me: Shadow stack is not enabled." + } + -re -wrap "void" { + # In case we don't have hardware or kernel support. + verbose -log "$me: No shadow stack support." + } + } + + gdb_exit + } + + remote_file build delete $obj + + verbose "$me: returning $allow_ssp_tests" 2 + return $allow_ssp_tests +} + # Run a test on the target to see if it supports avx512bf16. Return 1 if so, # 0 if it does not. Based on 'check_vmx_hw_available' from the GCC testsuite. @@ -4406,7 +4646,8 @@ gdb_caching_proc allow_lam_tests {} { # No error message, compilation succeeded so now run it via gdb. set allow_lam_tests 0 - clean_restart $obj + clean_restart + gdb_load $obj gdb_run_cmd gdb_expect { -re ".*$inferior_exited_re with code.*${gdb_prompt} $" { @@ -4454,7 +4695,7 @@ gdb_caching_proc allow_btrace_tests {} { gdb_start gdb_reinitialize_dir $srcdir/$subdir gdb_load $obj - if ![runto_main] { + if {![runto_main]} { return 0 } # In case of an unexpected output, we return 2 as a fail value. @@ -4505,7 +4746,7 @@ gdb_caching_proc allow_btrace_pt_tests {} { gdb_start gdb_reinitialize_dir $srcdir/$subdir gdb_load $obj - if ![runto_main] { + if {![runto_main]} { return 0 } # In case of an unexpected output, we return 2 as a fail value. @@ -4563,7 +4804,7 @@ gdb_caching_proc allow_btrace_ptw_tests {} { gdb_start gdb_reinitialize_dir $srcdir/$subdir gdb_load "$obj" - if ![runto_main] { + if {![runto_main]} { return 1 } @@ -4631,7 +4872,7 @@ gdb_caching_proc allow_btrace_pt_event_trace_tests {} { gdb_start gdb_reinitialize_dir $srcdir/$subdir gdb_load "$obj" - if ![runto_main] { + if {![runto_main]} { return 0 } @@ -4689,7 +4930,8 @@ gdb_caching_proc allow_aarch64_sve_tests {} { } # Compilation succeeded so now run it via gdb. - clean_restart $obj + clean_restart + gdb_load $obj gdb_run_cmd gdb_expect { -re ".*Illegal instruction.*${gdb_prompt} $" { @@ -4749,7 +4991,8 @@ gdb_caching_proc aarch64_initialize_sve_information { } { return [array get supported_vl] } - clean_restart $test_exec + clean_restart + gdb_load $test_exec if {![runto_main]} { return [array get supported_vl] @@ -4846,7 +5089,8 @@ gdb_caching_proc allow_aarch64_sme_tests {} { } # Compilation succeeded so now run it via gdb. - clean_restart $obj + clean_restart + gdb_load $obj gdb_run_cmd gdb_expect { -re ".*Illegal instruction.*${gdb_prompt} $" { @@ -4906,7 +5150,8 @@ gdb_caching_proc aarch64_initialize_sme_information { } { return [array get supported_svl] } - clean_restart $test_exec + clean_restart + gdb_load $test_exec if {![runto_main]} { return [array get supported_svl] @@ -5000,7 +5245,8 @@ gdb_caching_proc allow_aarch64_mops_tests {} { } # Compilation succeeded so now run it via gdb. - clean_restart $obj + clean_restart + gdb_load $obj gdb_run_cmd gdb_expect { -re ".*$inferior_exited_re with code 01.*${gdb_prompt} $" { @@ -5023,6 +5269,61 @@ gdb_caching_proc allow_aarch64_mops_tests {} { return $allow_mops_tests } +# Run a test on the target to see if it supports AArch64 GCS extensions. +# Return 1 if so, 0 if it does not. Note this causes a restart of GDB. + +gdb_caching_proc allow_aarch64_gcs_tests {} { + global srcdir subdir gdb_prompt inferior_exited_re + + set me "allow_aarch64_gcs_tests" + + if { ![is_aarch64_target]} { + return 0 + } + + # Compile a program that tests the GCS feature. + set src { + #include <stdbool.h> + #include <sys/auxv.h> + + /* Feature check for Guarded Control Stack. */ + #ifndef HWCAP_GCS + #define HWCAP_GCS (1ULL << 32) + #endif + + int main (void) { + bool gcs_supported = getauxval (AT_HWCAP) & HWCAP_GCS; + + /* Return success if GCS is supported. */ + return !gcs_supported; + } + } + + if {![gdb_simple_compile $me $src executable]} { + return 0 + } + + # Compilation succeeded so now run it via gdb. + set allow_gcs_tests 0 + clean_restart + gdb_load $obj + gdb_run_cmd + gdb_expect { + -re ".*$inferior_exited_re normally.*${gdb_prompt} $" { + verbose -log "\n$me: gcs support detected" + set allow_gcs_tests 1 + } + -re ".*$inferior_exited_re with code 01.*${gdb_prompt} $" { + verbose -log "\n$me: gcs support not detected" + } + } + gdb_exit + remote_file build delete $obj + + verbose "$me: returning $allow_gcs_tests" 2 + return $allow_gcs_tests +} + # A helper that compiles a test case to see if __int128 is supported. proc gdb_int128_helper {lang} { return [gdb_can_simple_compile "i128-for-$lang" { @@ -5043,12 +5344,12 @@ gdb_caching_proc has_int128_cxx {} { # Return true if the IFUNC feature is supported. gdb_caching_proc allow_ifunc_tests {} { - if [gdb_can_simple_compile ifunc { + if {[gdb_can_simple_compile ifunc { extern void f_ (); typedef void F (void); F* g (void) { return &f_; } void f () __attribute__ ((ifunc ("g"))); - } object] { + } object]} { return 1 } else { return 0 @@ -5056,7 +5357,7 @@ gdb_caching_proc allow_ifunc_tests {} { } # Return whether we should skip tests for showing inlined functions in -# backtraces. Requires get_compiler_info and get_debug_format. +# backtraces. Requires get_debug_format. proc skip_inline_frame_tests {} { # GDB only recognizes inlining information in DWARF. @@ -5075,7 +5376,7 @@ proc skip_inline_frame_tests {} { } # Return whether we should skip tests for showing variables from -# inlined functions. Requires get_compiler_info and get_debug_format. +# inlined functions. Requires get_debug_format. proc skip_inline_var_tests {} { # GDB only recognizes inlining information in DWARF. @@ -5086,6 +5387,40 @@ proc skip_inline_var_tests {} { return 0 } +# Return whether we allow running fork-related testcases. Targets +# that don't even have any concept of fork will just fail to compile +# the testcases and skip the tests that way if this returns true for +# them. Unix targets that do have a fork system call, but don't +# support intercepting forks will want to return false here, otherwise +# the testcases that exercise fork may hit a number of long cascading +# time out sequences. + +proc allow_fork_tests {} { + if {[istarget "*-*-cygwin*"] || [istarget "*-*-mingw*"]} { + return 0 + } + + return 1 +} + +# Return whether we allow running testcases that want to debug +# multiple inferiors with the same target. Not all targets support +# this. Note that some tests add a second inferior but never start +# it. Those tests should not be skipped due to this proc returning +# false. + +proc allow_multi_inferior_tests {} { + if {[istarget "*-*-cygwin*"] || [istarget "*-*-mingw*"]} { + return 0 + } + + if {[use_gdb_stub]} { + return 0 + } + + return 1 +} + # Return a 1 if we should run tests that require hardware breakpoints proc allow_hw_breakpoint_tests {} { @@ -5096,9 +5431,9 @@ proc allow_hw_breakpoint_tests {} { } # These targets support hardware breakpoints natively - if { [istarget "i?86-*-*"] + if { [istarget "i?86-*-*"] || [istarget "x86_64-*-*"] - || [istarget "ia64-*-*"] + || [istarget "ia64-*-*"] || [istarget "arm*-*-*"] || [istarget "aarch64*-*-*"] || [istarget "s390*-*-*"] } { @@ -5120,9 +5455,9 @@ proc allow_hw_watchpoint_tests {} { # Note, not all Power 9 processors support hardware watchpoints due to a HW # bug. Use has_hw_wp_support to check do a runtime check for hardware # watchpoint support on Powerpc. - if { [istarget "i?86-*-*"] + if { [istarget "i?86-*-*"] || [istarget "x86_64-*-*"] - || [istarget "ia64-*-*"] + || [istarget "ia64-*-*"] || [istarget "arm*-*-*"] || [istarget "aarch64*-*-*"] || ([istarget "powerpc*-*-linux*"] && [has_hw_wp_support]) @@ -5210,7 +5545,7 @@ proc skip_libstdcxx_probe_tests_prompt { prompt_regexp } { -re "\r\n$prompt_regexp" { } } - set skip [expr !$supported] + set skip [expr {!$supported}] return $skip } @@ -5281,7 +5616,7 @@ proc is_any_target {args} { proc use_gdb_stub {} { global use_gdb_stub - if [info exists use_gdb_stub] { + if {[info exists use_gdb_stub]} { return $use_gdb_stub } @@ -5313,14 +5648,6 @@ gdb_caching_proc target_is_gdbserver {} { return $is_gdbserver } -# N.B. compiler_info is intended to be local to this file. -# Call test_compiler_info with no arguments to fetch its value. -# Yes, this is counterintuitive when there's get_compiler_info, -# but that's the current API. -if [info exists compiler_info] { - unset compiler_info -} - # Figure out what compiler I am using. # The result is cached so only the first invocation runs the compiler. # @@ -5338,7 +5665,7 @@ if [info exists compiler_info] { # # [ catch "exec $compiler -E $ifile > $binfile.ci" exec_output ] # source $binfile.ci -# +# # This avoids the problem with -E and -o together. This almost works # if the build machine is the same as the host machine, which is # usually true of the targets which are not gcc. But this code does @@ -5363,7 +5690,7 @@ if [info exists compiler_info] { # Unfortunately, expect logs the output of the command as it goes by, # and dejagnu helpfully prints a second copy of it right afterwards. # So I turn off expect logging for a moment. -# +# # [ gdb_compile $ifile $ciexe_file executable $args ] # [ remote_exec $ciexe_file ] # [ source $ci_file.out ] @@ -5372,8 +5699,18 @@ if [info exists compiler_info] { # I didn't get desperate enough to try this. # # -- chastain 2004-01-06 +# +# Returns "unsupported" if LANGUAGE is not supported, and "unknown" if +# LANGUAGE is supported but extracting the information out of the +# compiler for LANGUAGE failed. Otherwise returns the compiler we're +# using for LANGUAGE. proc get_compiler_info {{language "c"}} { + # Split to a helper procedure because gdb_caching_proc does not + # support optional arguments. + return [get_compiler_info_1 $language] +} +gdb_caching_proc get_compiler_info_1 {language} { # For compiler.c, compiler.cc and compiler.F90. global srcdir @@ -5382,13 +5719,8 @@ proc get_compiler_info {{language "c"}} { global outdir global tool - # These come from compiler.c, compiler.cc or compiler.F90. - gdb_persistent_global compiler_info_cache - - if [info exists compiler_info_cache($language)] { - # Already computed. - return 0 - } + # 'compiler_info' comes from evaluating the result of + # preprocessing compiler.c, compiler.cc or compiler.F90. # Choose which file to preprocess. if { $language == "c++" } { @@ -5399,14 +5731,14 @@ proc get_compiler_info {{language "c"}} { set ifile "${srcdir}/lib/compiler.c" } else { perror "Unable to fetch compiler version for language: $language" - return -1 + return "unsupported" } # Run $ifile through the right preprocessor. # Toggle gdb.log to keep the compiler output out of the log. set saved_log [log_file -info] log_file - if [is_remote host] { + if {[is_remote host]} { # We have to use -E and -o together, despite the comments # above, because of how DejaGnu handles remote host testing. set ppout [standard_temp_file compiler.i] @@ -5423,7 +5755,7 @@ proc get_compiler_info {{language "c"}} { set ifile $tofile set cppout [ gdb_compile "${ifile}" "" preprocess [list "$language" quiet getting_compiler_info] ] } - eval log_file $saved_log + log_file {*}$saved_log # Eval the output. set unknown 0 @@ -5435,6 +5767,7 @@ proc get_compiler_info {{language "c"}} { } elseif { [ regexp "^\[\n\r\t \]*set\[\n\r\t \]" "$cppline" ] } { # eval this line verbose "get_compiler_info: $cppline" 2 + # tclint-disable-next-line command-args eval "$cppline" } elseif { [ regexp {[fc]lang.*warning.*'-fdiagnostics-color=never'} "$cppline"] } { # Both flang preprocessors (llvm flang and classic flang) print a @@ -5451,7 +5784,7 @@ proc get_compiler_info {{language "c"}} { } # Set to unknown if for some reason compiler_info didn't get defined. - if ![info exists compiler_info] { + if {![info exists compiler_info]} { verbose -log "get_compiler_info: compiler_info not provided" set compiler_info "unknown" } @@ -5461,26 +5794,25 @@ proc get_compiler_info {{language "c"}} { set compiler_info "unknown" } - set compiler_info_cache($language) $compiler_info - # Log what happened. verbose -log "get_compiler_info: $compiler_info" - return 0 + return $compiler_info } -# Return the compiler_info string if no arg is provided. -# Otherwise the argument is a glob-style expression to match against -# compiler_info. +# Return the compiler_info string if COMPILER is not provided. +# Otherwise COMPILER is a glob-style expression to match against +# compiler_info, and this returns true/false depending on whether the +# expression matches or not. proc test_compiler_info { {compiler ""} {language "c"} } { - gdb_persistent_global compiler_info_cache + set compiler_info [get_compiler_info $language] - if [get_compiler_info $language] { + if {$compiler_info == "unsupported"} { # An error will already have been printed in this case. Just # return a suitable result depending on how the user called # this function. - if [string match "" $compiler] { + if {[string match "" $compiler]} { return "" } else { return false @@ -5488,11 +5820,11 @@ proc test_compiler_info { {compiler ""} {language "c"} } { } # If no arg, return the compiler_info string. - if [string match "" $compiler] { - return $compiler_info_cache($language) + if {[string match "" $compiler]} { + return $compiler_info } - return [string match $compiler $compiler_info_cache($language)] + return [string match $compiler $compiler_info] } # Return true if the C compiler is GCC, otherwise, return false. @@ -5530,7 +5862,7 @@ proc gcc_major_version { {compiler "gcc-*"} {language "c"} } { proc current_target_name { } { global target_info - if [info exists target_info(target,name)] { + if {[info exists target_info(target,name)]} { set answer $target_info(target,name) } else { set answer "" @@ -5556,7 +5888,7 @@ proc gdb_wrapper_init { args } { set result [build_wrapper "testglue.o"] if { $result != "" } { set gdb_wrapper_file [lindex $result 0] - if ![is_remote host] { + if {![is_remote host]} { set gdb_wrapper_file [file join [pwd] $gdb_wrapper_file] } set gdb_wrapper_flags [lindex $result 1] @@ -5665,6 +5997,10 @@ proc gdb_simple_compile {name code {type object} {compile_flags {}} {object obj} set ext "d" break } + if { "$flag" eq "rust" } { + set ext "rs" + break + } } set src [standard_temp_file $name.$ext] set obj [standard_temp_file $name.$postfix] @@ -5971,7 +6307,7 @@ proc gdb_compile {source dest type options} { foreach opt $options { if {[regexp {^shlib=(.*)} $opt dummy_var shlib_name] && $type == "executable"} { - if [test_compiler_info "xlc-*"] { + if {[test_compiler_info "xlc-*"]} { # IBM xlc compiler doesn't accept shared library named other # than .so: use "-Wl," to bypass this lappend source "-Wl,$shlib_name" @@ -6098,7 +6434,7 @@ proc gdb_compile {source dest type options} { } set options $new_options - if [info exists GDB_TESTCASE_OPTIONS] { + if {[info exists GDB_TESTCASE_OPTIONS]} { lappend options "additional_flags=$GDB_TESTCASE_OPTIONS" } verbose "options are $options" @@ -6117,7 +6453,7 @@ proc gdb_compile {source dest type options} { # to disable compiler warnings. set nowarnings [lsearch -exact $options nowarnings] if {$nowarnings != -1} { - if [target_info exists gdb,nowarnings_flag] { + if {[target_info exists gdb,nowarnings_flag]} { set flag "additional_flags=[target_info gdb,nowarnings_flag]" } else { set flag "additional_flags=-w" @@ -6129,7 +6465,7 @@ proc gdb_compile {source dest type options} { # to enable PIE executables. set pie [lsearch -exact $options pie] if {$pie != -1} { - if [target_info exists gdb,pie_flag] { + if {[target_info exists gdb,pie_flag]} { set flag "additional_flags=[target_info gdb,pie_flag]" } else { # For safety, use fPIE rather than fpie. On AArch64, m68k, PowerPC @@ -6142,7 +6478,7 @@ proc gdb_compile {source dest type options} { } set options [lreplace $options $pie $pie $flag] - if [target_info exists gdb,pie_ldflag] { + if {[target_info exists gdb,pie_ldflag]} { set flag "ldflags=[target_info gdb,pie_ldflag]" } else { set flag "ldflags=-pie" @@ -6154,14 +6490,14 @@ proc gdb_compile {source dest type options} { # flags to disable PIE executables. set nopie [lsearch -exact $options nopie] if {$nopie != -1} { - if [target_info exists gdb,nopie_flag] { + if {[target_info exists gdb,nopie_flag]} { set flag "additional_flags=[target_info gdb,nopie_flag]" } else { set flag "additional_flags=-fno-pie" } set options [lreplace $options $nopie $nopie $flag] - if [target_info exists gdb,nopie_ldflag] { + if {[target_info exists gdb,nopie_ldflag]} { set flag "ldflags=[target_info gdb,nopie_ldflag]" } else { set flag "ldflags=-no-pie" @@ -6243,7 +6579,10 @@ proc gdb_compile {source dest type options} { } } - cond_wrap [expr $pie != -1 || $nopie != -1] \ + # Automatically handle includes in testsuite/lib/. + auto_lappend_include_files options $source + + cond_wrap [expr {$pie != -1 || $nopie != -1}] \ with_PIE_multilib_flags_filtered { set result [target_compile $source $dest $type $options] } @@ -6264,7 +6603,7 @@ proc gdb_compile {source dest type options} { regsub "\[\r\n\]*$" "$result" "" result regsub "^\[\r\n\]*" "$result" "" result - + if { $type == "executable" && $result == "" \ && ($nopie != -1 || $pie != -1) } { set is_pie [exec_is_pie "$dest"] @@ -6380,7 +6719,7 @@ proc gdb_compile_shlib_1 {sources dest options} { lappend objects $source continue } - + set sourcebase [file tail $source] if { $ada } { @@ -6414,7 +6753,7 @@ proc gdb_compile_shlib_1 {sources dest options} { set idx [lsearch $link_options "ada"] set link_options [lreplace $link_options $idx $idx] } - if [test_compiler_info "xlc-*"] { + if {[test_compiler_info "xlc-*"]} { lappend link_options "additional_flags=-qmkshrobj" } else { lappend link_options "additional_flags=-shared" @@ -6595,6 +6934,7 @@ proc send_gdb { string {type standard}} { proc send_inferior { string } { global inferior_spawn_id + # tclint-disable-next-line command-args if {[catch "send -i $inferior_spawn_id -- \$string" errorInfo]} { return "$errorInfo" } else { @@ -6615,7 +6955,7 @@ proc gdb_expect { args } { # A timeout argument takes precedence, otherwise of all the timeouts # select the largest. - if [info exists atimeout] { + if {[info exists atimeout]} { set tmt $atimeout } else { set tmt [get_largest_timeout] @@ -6653,7 +6993,7 @@ proc gdb_expect_list {test sentinel list} { while { ${index} < [llength ${list}] } { set pattern [lindex ${list} ${index}] - set index [expr ${index} + 1] + incr index verbose -log "gdb_expect_list pattern: /$pattern/" 2 if { ${index} == [llength ${list}] } { if { ${ok} } { @@ -6778,7 +7118,20 @@ gdb_caching_proc can_spawn_for_attach {} { set me "can_spawn_for_attach" set src { - #include <unistd.h> + #ifdef _WIN32 + # include <windows.h> + #else + # include <unistd.h> + #endif + + #ifdef _WIN32 + unsigned + sleep (unsigned seconds) + { + Sleep (seconds * 1000); + return 0; + } + #endif int main (void) @@ -6848,7 +7201,7 @@ proc gdb_attach { testpid args } { # Return 1 if GDB managed to start and attach to the process, 0 otherwise. proc_with_prefix gdb_spawn_attach_cmdline { testpid } { - if ![can_spawn_for_attach] { + if {![can_spawn_for_attach]} { # The caller should have checked can_spawn_for_attach itself # before getting here. error "can't spawn for attach with this target/board" @@ -6901,7 +7254,7 @@ proc kill_wait_spawned_process { proc_spawn_id } { remote_exec build "kill -9 ${pid}" verbose -log "closing ${proc_spawn_id}" - catch "close -i $proc_spawn_id" + catch {close -i $proc_spawn_id} verbose -log "waiting for ${proc_spawn_id}" # If somehow GDB ends up still attached to the process here, a @@ -6919,7 +7272,7 @@ proc kill_wait_spawned_process { proc_spawn_id } { proc spawn_id_get_pid { spawn_id } { set testpid [exp_pid -i $spawn_id] - if { [istarget "*-*-cygwin*"] } { + if { [istarget "*-*-cygwin*"] || [istarget "*-*-mingw*"] } { # testpid is the Cygwin PID, GDB uses the Windows PID, which # might be different due to the way fork/exec works. set testpid [ exec ps -e | gawk "{ if (\$1 == $testpid) print \$4; }" ] @@ -6953,7 +7306,7 @@ proc spawn_wait_for_attach_1 { executable_list } { # this when [can_spawn_for_attach] is false. proc spawn_wait_for_attach { executable_list } { - if ![can_spawn_for_attach] { + if {![can_spawn_for_attach]} { # The caller should have checked can_spawn_for_attach itself # before getting here. error "can't spawn for attach with this target/board" @@ -6970,7 +7323,7 @@ proc spawn_wait_for_attach { executable_list } { proc gdb_load_cmd { args } { global gdb_prompt - if [target_info exists gdb_load_timeout] { + if {[target_info exists gdb_load_timeout]} { set loadtimeout [target_info gdb_load_timeout] } else { set loadtimeout 1600 @@ -7006,6 +7359,24 @@ proc gdb_load_cmd { args } { return -1 } +# Return non-zero if 'gcore' command is available. +gdb_caching_proc gcore_cmd_available { } { + gdb_exit + gdb_start + + # Does this gdb support gcore? + gdb_test_multiple "help gcore" "" { + -re -wrap "Undefined command: .*" { + return 0 + } + -re -wrap "Save a core file .*" { + return 1 + } + } + + return 0 +} + # Invoke "gcore". CORE is the name of the core file to write. TEST # is the name of the test case. This will return 1 if the core file # was created, 0 otherwise. If this fails to make a core file because @@ -7209,7 +7580,7 @@ proc gdb_download_shlib { file } { proc gdb_locate_shlib { file } { global gdb_spawn_id - if ![info exists gdb_spawn_id] { + if {![info exists gdb_spawn_id]} { perror "gdb_load_shlib: GDB is not running" } @@ -7371,13 +7742,13 @@ proc clean_standard_output_dir {} { } # Directory containing the standard output files. - set standard_output_dir [file normalize [standard_output_file ""]] + set standard_output_dir [build_standard_output_file ""] # Ensure that standard_output_dir is clean, or only contains # gdb.log / gdb.sum. set log_file_info [split [log_file -info]] set log_file [file normalize [lindex $log_file_info end]] - if { $log_file == [file normalize [standard_output_file gdb.log]] } { + if { $log_file == [file normalize [build_standard_output_file gdb.log]] } { # Dir already contains active gdb.log. Don't remove the dir, but # check that it's clean otherwise. set res [glob -directory $standard_output_dir -tails *] @@ -7409,7 +7780,7 @@ proc default_gdb_init { test_file_name } { global cleanfiles_target global cleanfiles_host global pf_prefix - + # Reset the timeout value to the default. This way, any testcase # that changes the timeout value without resetting it cannot affect # the timeout used in subsequent testcases. @@ -7452,7 +7823,7 @@ proc default_gdb_init { test_file_name } { global banned_variables global banned_procedures global banned_traced - if (!$banned_traced) { + if {!$banned_traced} { foreach banned_var $banned_variables { global "$banned_var" trace add variable "$banned_var" write error @@ -7470,6 +7841,22 @@ proc default_gdb_init { test_file_name } { setenv LC_CTYPE C setenv LANG C + # With MSYS2 and TERM={xterm,ansi}, I get: + # + # builtin_spawn gdb -q ... + # ^[[6n(gdb) + # + # While we're addressing this in default_gdb_start, this is not specific + # to gdb, other tools produce the same CSI sequence, and consequently we + # run into trouble in other places (like get_compiler_info). + # + # Set TERM to dumb to prevent the '^[[6n' from occurring. + # + # We could do this only for ishost *-*-mingw*, but that introduces + # inconsistency between platforms, with test-cases passing on one platform + # but failing on the other. So, we do this for all platforms. + setenv TERM dumb + # Don't let a .inputrc file or an existing setting of INPUTRC mess # up the test results. Certain tests (style tests and TUI tests) # want to set the terminal to a non-"dumb" value, and for those we @@ -7546,26 +7933,26 @@ proc default_gdb_init { test_file_name } { if { $gdb_wrapper_target != [current_target_name] } { set gdb_wrapper_initialized 0 } - + # Unlike most tests, we have a small number of tests that generate # a very large amount of output. We therefore increase the expect # buffer size to be able to contain the entire test output. This # is especially needed by gdb.base/info-macros.exp. match_max -d 65536 - # Also set this value for the currently running GDB. + # Also set this value for the currently running GDB. match_max [match_max -d] # We want to add the name of the TCL testcase to the PASS/FAIL messages. set pf_prefix "[file tail [file dirname $test_file_name]]/[file tail $test_file_name]:" global gdb_prompt - if [target_info exists gdb_prompt] { + if {[target_info exists gdb_prompt]} { set gdb_prompt [target_info gdb_prompt] } else { set gdb_prompt "\\(gdb\\)" } global use_gdb_stub - if [info exists use_gdb_stub] { + if {[info exists use_gdb_stub]} { unset use_gdb_stub } @@ -7607,31 +7994,48 @@ proc default_gdb_init { test_file_name } { proc make_gdb_parallel_path { args } { global GDB_PARALLEL objdir - set joiner [list "file" "join" $objdir] + set joiner [list $objdir] if { [info exists GDB_PARALLEL] && $GDB_PARALLEL != "yes" } { lappend joiner $GDB_PARALLEL } set joiner [concat $joiner $args] - return [eval $joiner] + return [file join {*}$joiner] } # Turn BASENAME into a full file name in the standard output -# directory. It is ok if BASENAME is the empty string; in this case -# the directory is returned. +# directory, as seen from the build machine. I.e., as seen from the +# system driving DejaGnu. (E.g., if DejaGnu is being driven by MSYS2 +# to test native Windows GDB, the "build" file names should be file +# names TCL understands, i.e., Unix file names.) It is OK if BASENAME +# is the empty string; in this case the directory is returned. -proc standard_output_file {basename} { +proc build_standard_output_file {basename} { global objdir subdir gdb_test_file_name set dir [make_gdb_parallel_path outputs $subdir $gdb_test_file_name] file mkdir $dir - # If running on MinGW, replace /c/foo with c:/foo - if { [ishost *-*-mingw*] } { - set dir [exec sh -c "cd ${dir} && pwd -W"] - } return [file join $dir $basename] } -# Turn BASENAME into a file name on host. +# Turn BASENAME into a full file name in the standard output +# directory, as seen from a non-remote host. I.e., assuming the build +# and the host share the filesystem. E.g., if DejaGnu is being driven +# by MSYS2 to test native Windows GDB, the "host" file names should be +# file names GDB understands, i.e., Windows file names. It is OK if +# BASENAME is the empty string; in this case the directory is +# returned. + +proc standard_output_file {basename} { + global objdir subdir gdb_test_file_name + + set dir [make_gdb_parallel_path outputs $subdir $gdb_test_file_name] + file mkdir $dir + set dir [host_file_normalize $dir] + return [host_file_join $dir $basename] +} + +# Like standard_output_file, but handles remote hosts. Turn BASENAME +# into a file name on (potentially remote) host. proc host_standard_output_file { basename } { if { [is_remote host] } { @@ -7805,7 +8209,7 @@ proc standard_testfile {args} { # the same timeout as the default dejagnu timeout, unless the user has # already provided a specific value (probably through a site.exp file). global gdb_test_timeout -if ![info exists gdb_test_timeout] { +if {![info exists gdb_test_timeout]} { set gdb_test_timeout $timeout } @@ -7864,9 +8268,12 @@ proc gdb_cleanup_globals {} { # proc. set temp [interp create] if { [interp eval $temp "info procs ::unknown"] != "" } { + # tclint-disable-next-line command-args set old_args [interp eval $temp "info args ::unknown"] + # tclint-disable-next-line command-args set old_body [interp eval $temp "info body ::unknown"] - eval proc gdb_tcl_unknown {$old_args} {$old_body} + # tclint-disable-next-line command-args + proc gdb_tcl_unknown $old_args $old_body } interp delete $temp unset temp @@ -7901,11 +8308,11 @@ proc gdb_finish { } { gdb_exit if { [llength $cleanfiles_target] > 0 } { - eval remote_file target delete $cleanfiles_target + remote_file target delete {*}$cleanfiles_target set cleanfiles_target {} } if { [llength $cleanfiles_host] > 0 } { - eval remote_file host delete $cleanfiles_host + remote_file host delete {*}$cleanfiles_host set cleanfiles_host {} } @@ -7914,7 +8321,7 @@ proc gdb_finish { } { global banned_variables global banned_procedures global banned_traced - if ($banned_traced) { + if {$banned_traced} { foreach banned_var $banned_variables { global "$banned_var" trace remove variable "$banned_var" write error @@ -7978,7 +8385,7 @@ proc get_debug_format { } { proc test_debug_format {format} { global debug_format - return [expr [string match $format $debug_format] != 0] + return [expr {[string match $format $debug_format] != 0}] } # Like setup_xfail, but takes the name of a debug format (DWARF 1, @@ -8000,7 +8407,7 @@ proc setup_xfail_format { format } { # # Search the source file FILE, and return the line number of the # first line containing TEXT. If no match is found, an error is thrown. -# +# # TEXT is a string literal, not a regular expression. # # The default value of FILE is "$srcdir/$subdir/$srcfile". If FILE is @@ -8012,18 +8419,18 @@ proc setup_xfail_format { format } { # # Use this function to keep your test scripts independent of the # exact line numbering of the source file. Don't write: -# +# # send_gdb "break 20" -# -# This means that if anyone ever edits your test's source file, +# +# This means that if anyone ever edits your test's source file, # your test could break. Instead, put a comment like this on the # source file line you want to break at: -# +# # /* breakpoint spot: frotz.exp: test name */ -# +# # and then write, in your test script (which we assume is named # frotz.exp): -# +# # send_gdb "break [gdb_get_line_number "frotz.exp: test name"]\n" # # (Yes, Tcl knows how to handle the nested quotes and brackets. @@ -8031,7 +8438,7 @@ proc setup_xfail_format { format } { # $ tclsh # % puts "foo [lindex "bar baz" 1]" # foo baz -# % +# % # Tcl is quite clever, for a little stringy language.) # # === @@ -8148,7 +8555,7 @@ proc gdb_continue_to_end {{mssg ""} {command continue} {allow_extra 0}} { if { [target_info exists exit_is_reliable] } { set exit_is_reliable [target_info exit_is_reliable] } else { - set exit_is_reliable [expr ! $use_gdb_stub] + set exit_is_reliable [expr {! $use_gdb_stub}] } if { ! $exit_is_reliable } { @@ -8170,7 +8577,7 @@ proc gdb_continue_to_end {{mssg ""} {command continue} {allow_extra 0}} { proc rerun_to_main {} { global gdb_prompt use_gdb_stub - if $use_gdb_stub { + if {$use_gdb_stub} { gdb_run_cmd gdb_expect { -re ".*Breakpoint .*main .*$gdb_prompt $"\ @@ -8268,7 +8675,7 @@ proc exec_is_pie { executable } { # registers. gdb_caching_proc allow_float_test {} { - if [target_info exists gdb,skip_float_tests] { + if {[target_info exists gdb,skip_float_tests]} { return 0 } @@ -8366,7 +8773,7 @@ gdb_caching_proc allow_float_test {} { # due to lack of stdio support. proc gdb_skip_stdio_test { msg } { - if [target_info exists gdb,noinferiorio] { + if {[target_info exists gdb,noinferiorio]} { verbose "Skipping test '$msg': no inferior i/o." return 1 } @@ -8478,7 +8885,7 @@ gdb_caching_proc gdb_has_argv0 {} { -re "${gdb_prompt} $" { } } - + gdb_test_no_output "set print elements $old_elements" "" gdb_test_no_output "set print repeats $old_repeats" "" @@ -8545,7 +8952,7 @@ proc get_build_id { filename } { } else { set tmp [standard_output_file "${filename}-tmp"] set objcopy_program [gdb_find_objcopy] - set result [catch "exec $objcopy_program -j .note.gnu.build-id -O binary $filename $tmp" output] + set result [catch {exec $objcopy_program -j .note.gnu.build-id -O binary $filename $tmp} output] verbose "result is $result" verbose "output is $output" if {$result == 1} { @@ -8614,7 +9021,7 @@ proc gdb_gnu_strip_debug { dest args } { # Get rid of the debug info, and store result in stripped_file # something like gdb/testsuite/gdb.base/blah.stripped. - set result [catch "exec $strip_to_file_program --strip-debug ${dest} -o ${stripped_file}" output] + set result [catch {exec $strip_to_file_program --strip-debug ${dest} -o ${stripped_file}} output] verbose "result is $result" verbose "output is $output" if {$result == 1} { @@ -8628,7 +9035,7 @@ proc gdb_gnu_strip_debug { dest args } { # Get rid of everything but the debug info, and store result in debug_file # This will be in the .debug subdirectory, see above. - set result [catch "exec $strip_to_file_program --only-keep-debug ${dest} -o ${debug_file}" output] + set result [catch {exec $strip_to_file_program --only-keep-debug ${dest} -o ${debug_file}} output] verbose "result is $result" verbose "output is $output" if {$result == 1} { @@ -8641,7 +9048,7 @@ proc gdb_gnu_strip_debug { dest args } { # objcopy or strip to remove the symbol table without also removing the # debugging sections, so this is as close as we can get. if {[lsearch -exact $args "no-main"] != -1} { - set result [catch "exec $objcopy_program -N main ${debug_file} ${debug_file}-tmp" output] + set result [catch {exec $objcopy_program -N main ${debug_file} ${debug_file}-tmp} output] verbose "result is $result" verbose "output is $output" if {$result == 1} { @@ -8656,7 +9063,7 @@ proc gdb_gnu_strip_debug { dest args } { # section to the stripped_file, containing a pointer to the # debug_file. if {[lsearch -exact $args "no-debuglink"] == -1} { - set result [catch "exec $objcopy_program --add-gnu-debuglink=${debug_file} ${stripped_file} ${stripped_file}-tmp" output] + set result [catch {exec $objcopy_program --add-gnu-debuglink=${debug_file} ${stripped_file} ${stripped_file}-tmp} output] verbose "result is $result" verbose "output is $output" if {$result == 1} { @@ -8744,12 +9151,12 @@ proc test_user_defined_class_help { {list_of_commands {}} {testname {}} } { # element is abbreviation of. # The command must be a prefix command. EXPECTED_INITIAL_LINES # are regular expressions that should match the beginning of output, -# before the list of subcommands. The presence of +# before the list of subcommands. The presence of # subcommand list and standard epilogue will be tested automatically. proc test_prefix_command_help { command_list expected_initial_lines args } { global help_list_trailer - set command [lindex $command_list 0] - if {[llength $command_list]>1} { + set command [lindex $command_list 0] + if {[llength $command_list]>1} { set full_command [lindex $command_list 1] } else { set full_command $command @@ -8793,7 +9200,7 @@ proc build_executable_from_specs {testname executable options args} { # gdb_compile_shlib and gdb_compile_shlib_pthreads do not use the 3rd # parameter. They also requires $sources while gdb_compile and # gdb_compile_pthreads require $objects. Moreover they ignore any options. - if [string match gdb_compile_shlib* $func] { + if {[string match gdb_compile_shlib* $func]} { set sources_path {} foreach {s local_options} $args { if {[regexp "^/" "$s"]} { @@ -8851,7 +9258,7 @@ proc build_executable { testname executable {sources ""} {options {debug}} } { lappend arglist $source $options } - return [eval build_executable_from_specs $arglist] + return [build_executable_from_specs {*}$arglist] } # Starts fresh GDB binary and loads an optional executable into GDB. @@ -8885,6 +9292,10 @@ proc clean_restart {{executable ""}} { gdb_reinitialize_dir $srcdir/$subdir if {$executable != ""} { + if { [file pathtype $executable] == "absolute" } { + error "absolute path used" + } + set binfile [standard_output_file ${executable}] return [gdb_load ${binfile}] } @@ -8902,7 +9313,7 @@ proc clean_restart {{executable ""}} { # Returns 0 on success, non-zero on failure. proc prepare_for_testing_full {testname args} { foreach spec $args { - if {[eval build_executable_from_specs [list $testname] $spec] == -1} { + if {[build_executable_from_specs $testname {*}$spec] == -1} { return -1 } set executable [lindex $spec 0] @@ -9135,8 +9546,9 @@ gdb_caching_proc target_endianness {} { return 0 } - clean_restart $obj - if ![runto_main] { + clean_restart + gdb_load $obj + if {![runto_main]} { return 0 } set res [get_endianness] @@ -9158,12 +9570,12 @@ proc relative_filename {root full} { set len [llength $root_split] - if {[eval file join $root_split] - != [eval file join [lrange $full_split 0 [expr {$len - 1}]]]} { + if {[file join {*}$root_split] + != [file join {*}[lrange $full_split 0 [expr {$len - 1}]]]} { error "$full not a subdir of $root" } - return [eval file join [lrange $full_split $len end]] + return [file join {*}[lrange $full_split $len end]] } # If GDB_PARALLEL exists, then set up the parallel-mode directories. @@ -9261,7 +9673,13 @@ proc remove_core {pid {test ""}} { } } -proc core_find {binfile {deletefiles {}} {arg ""}} { +# Runs ${binfile} expecting it to crash and generate a core file. +# If DELETEFILES is provided, remove these files after running the program. +# If ARG is provided, pass it as a command line argument to the program. +# If OUTPUT_FILE is provided, save the program output to it. +# Returns the name of the core dump, or empty string if not found. + +proc core_find {binfile {deletefiles {}} {arg ""} {output_file "/dev/null"}} { global objdir subdir set destcore "$binfile.core" @@ -9283,10 +9701,16 @@ proc core_find {binfile {deletefiles {}} {arg ""}} { set found 0 set coredir [standard_output_file coredir.[getpid]] file mkdir $coredir - catch "system \"(cd ${coredir}; ulimit -c unlimited; ${binfile} ${arg}; true) >/dev/null 2>&1\"" + # tclint-disable command-args + catch "system \"(cd ${coredir}; ulimit -c unlimited; ${binfile} ${arg}; true) >${output_file} 2>&1\"" # remote_exec host "${binfile}" - foreach i "${coredir}/core ${coredir}/core.coremaker.c ${binfile}.core" { - if [remote_file build exists $i] { + set binfile_basename [file tail $binfile] + foreach i [list \ + ${coredir}/core \ + ${coredir}/core.coremaker.c \ + ${coredir}/${binfile_basename}.core \ + ${coredir}/${binfile_basename}.exe.core] { + if {[remote_file build exists $i]} { remote_exec build "mv $i $destcore" set found 1 } @@ -9308,21 +9732,22 @@ proc core_find {binfile {deletefiles {}} {arg ""}} { # ulimit here if we didn't find a core file above. # Oh, I should mention that any "braindamaged" non-Unix system has # the same problem. I like the cd bit too, it's really neat'n stuff. + # tclint-disable command-args catch "system \"(cd ${objdir}/${subdir}; ${binfile}; true) >/dev/null 2>&1\"" foreach i "${objdir}/${subdir}/core ${objdir}/${subdir}/core.coremaker.c ${binfile}.core" { - if [remote_file build exists $i] { + if {[remote_file build exists $i]} { remote_exec build "mv $i $destcore" set found 1 } } } - # Try to clean up after ourselves. + # Try to clean up after ourselves. foreach deletefile $deletefiles { remote_file build delete [file join $coredir $deletefile] } remote_exec build "rmdir $coredir" - + if { $found == 0 } { warning "can't generate a core file - core tests suppressed - check ulimit -c" return "" @@ -9344,7 +9769,7 @@ gdb_caching_proc gdb_target_symbol_prefix {} { set prefix "" set objdump_program [gdb_find_objdump] - set result [catch "exec $objdump_program --syms $obj" output] + set result [catch {exec $objdump_program --syms $obj} output] if { $result == 0 \ && ![regexp -lineanchor \ @@ -9369,8 +9794,9 @@ gdb_caching_proc target_supports_scheduler_locking {} { return 0 } - clean_restart $obj - if ![runto_main] { + clean_restart + gdb_load $obj + if {![runto_main]} { return 0 } @@ -9447,7 +9873,7 @@ proc gdb_target_symbol { symbol } { # surrounding the prefix. It is used to define the macro # SYMBOL_PREFIX for assembly language files. Another version, below, # is used for symbols in inline assembler in C/C++ files. -# +# # The lack of quotes in this version (_asm) makes it possible to # define supporting macros in the .S file. (The version which # uses quotes for the prefix won't work for such files since it's @@ -9495,7 +9921,7 @@ proc run_on_host { test program args } { if {[llength $args] > 1 && [lindex $args 1] == ""} { set args [lreplace $args 1 1 "/dev/null"] } - set result [eval remote_exec host [list $program] $args] + set result [remote_exec host $program {*}$args] verbose "result is $result" set status [lindex $result 0] set output [lindex $result 1] @@ -9583,11 +10009,11 @@ proc parse_list { level listname argset prefix eval } { set result [lsearch -exact $args $pattern] if {$result != -1} { - set value [lindex $args [expr $result+1]] + set value [lindex $args [expr {$result+1}]] if { $eval } { - set value [uplevel [expr $level + 1] [list subst $value]] + set value [uplevel [expr {$level + 1}] [list subst $value]] } - set args [lreplace $args $result [expr $result+1]] + set args [lreplace $args $result [expr {$result+1}]] } else { set value [lindex $argument 1] if { $eval } { @@ -9763,6 +10189,7 @@ proc gdb_define_cmd {command command_list} { # relative path name, and, we sometimes need to close/reopen the log # after changing the current directory. See get_compiler_info. +# tclint-disable redefined-builtin rename cd builtin_cd proc cd { dir } { @@ -9774,7 +10201,7 @@ proc cd { dir } { set log_file_flags "" set log_file_file "" foreach arg [ split "$log_file_info" " "] { - if [string match "-*" $arg] { + if {[string match "-*" $arg]} { lappend log_file_flags $arg } else { lappend log_file_file $arg @@ -9827,9 +10254,9 @@ proc gdb_debug_enabled { } { # If not already read, get the debug setting from environment or board setting. if {![info exists gdbdebug]} { global env - if [info exists env(GDB_DEBUG)] { + if {[info exists env(GDB_DEBUG)]} { set gdbdebug $env(GDB_DEBUG) - } elseif [target_info exists gdb,debug] { + } elseif {[target_info exists gdb,debug]} { set gdbdebug [target_info gdb,debug] } else { return 0 @@ -9846,7 +10273,7 @@ proc gdb_debug_init { } { global gdb_prompt - if ![gdb_debug_enabled] { + if {![gdb_debug_enabled]} { return; } @@ -9884,12 +10311,16 @@ proc gdb_stdin_log_init { } { gdb_persistent_global in_file if {[info exists in_file]} { - # Close existing file. - catch "close $in_file" + # Close existing file. + catch {close $in_file} } set logfile [standard_output_file_with_gdb_instance gdb.in] set in_file [open $logfile w] + + verbose -log "" + verbose -log "Starting logfile: $logfile" + verbose -log "" } # Write to the file for logging gdb input. @@ -9927,7 +10358,7 @@ proc gdb_write_cmd_file { cmdline } { set logfile [standard_output_file_with_gdb_instance gdb.cmd] set cmd_file [open $logfile w] puts $cmd_file $cmdline - catch "close $cmd_file" + catch {close $cmd_file} } # Compare contents of FILE to string STR. Pass with MSG if equal, otherwise @@ -10103,7 +10534,7 @@ proc add_gdb_index { program {style ""} } { global srcdir GDB env set contrib_dir "$srcdir/../contrib" set env(GDB) [append_gdb_data_directory_option $GDB] - set result [catch "exec $contrib_dir/gdb-add-index.sh $style $program" output] + set result [catch {exec $contrib_dir/gdb-add-index.sh {*}$style $program} output] if { $result != 0 } { verbose -log "result is $result" verbose -log "output is $output" @@ -10247,7 +10678,7 @@ proc hex_in_list { val hexlist } { set re 0x0*$val set index [lsearch -regexp $hexlist $re] - return [expr $index != -1] + return [expr {$index != -1}] } # As info args, but also add the default values. @@ -10295,14 +10726,16 @@ proc with_override { name override body } { # Install the override. set new_args [info_args_with_defaults $override] set new_body [info body $override] - eval proc $name {$new_args} {$new_body} + # tclint-disable-next-line command-args + proc $name $new_args $new_body # Execute body. set code [catch {uplevel 1 $body} result] # Restore old proc if it existed on entry, else delete it. if { $existed } { - eval proc $name {$old_args} {$old_body} + # tclint-disable-next-line command-args + proc $name $old_args $old_body } else { rename $name "" } @@ -10323,7 +10756,11 @@ proc with_override { name override body } { proc with_ansi_styling_terminal { body } { save_vars { ::env(TERM) ::env(NO_COLOR) ::env(COLORTERM) } { # Set environment variables to allow styling. - setenv TERM ansi + if { [ishost *-*-*bsd*] } { + setenv TERM ansiw + } else { + setenv TERM ansi + } unset -nocomplain ::env(NO_COLOR) unset -nocomplain ::env(COLORTERM) @@ -10625,7 +11062,7 @@ gdb_caching_proc has_hw_wp_support {} { gdb_reinitialize_dir $srcdir/$subdir gdb_load "$obj" - if ![runto_main] { + if {![runto_main]} { gdb_exit remote_file build delete $obj @@ -10712,7 +11149,7 @@ gdb_caching_proc arm_cc_for_target {} { # produced binary actually runs on the system before declaring # we've found the right compiler. - if [istarget "*-linux*-*"] { + if {[istarget "*-linux*-*"]} { set compilers { arm-linux-gnueabi-gcc arm-none-linux-gnueabi-gcc @@ -10856,7 +11293,8 @@ gdb_caching_proc have_epilogue_line_info {} { return False } - clean_restart $obj + clean_restart + gdb_load $obj gdb_test_multiple "info line 6" "epilogue test" { -re -wrap ".*starts at address.*and ends at.*" { @@ -10999,6 +11437,66 @@ proc lappend_include_file { flags file } { } } +# Helper for auto_lappend_include_files that handles one source file, +# and tracks the list of already-visited files. + +proc auto_lappend_include_files_1 {flags source {visited {}}} { + upvar $flags up_flags + upvar $visited up_visited + global srcdir + + set ext [string tolower [file extension $source]] + if {$ext ni {".c" ".cpp" ".cc" ".h" ".s"}} { + return + } + + if {[catch {open $source r} fh err]} { + error "Failed to open file '$source': $err" + } + set contents [read $fh] + close $fh + + lappend up_visited $source + + # Match lines like: + # #include "gdb_foo.h" + set re "^\\s*#include\\s+\"(.*)\"" + + foreach line [split $contents "\n"] { + if {[regexp $re $line -> basename]} { + set lib_file "$srcdir/lib/$basename" + + # If already processed, skip. + if {[lsearch -exact $up_visited $lib_file] != -1} { + continue + } + + if {![file exists $lib_file]} { + continue + } + + # Append to include list, and recurse into the included + # file. + lappend_include_file up_flags $lib_file + auto_lappend_include_files_1 up_flags $lib_file up_visited + } + } +} + +# Automatically handle includes under gdb/testsuite/lib/. +# +# For each source file in SOURCES, look for #include directives +# including files that live in testsuite/lib/. For each such included +# file, call lappend_include_file for it. + +proc auto_lappend_include_files {flags sources} { + upvar $flags up_flags + set visited {} + foreach src $sources { + auto_lappend_include_files_1 up_flags $src visited + } +} + # Return a list of supported host locales. gdb_caching_proc host_locales { } { @@ -11034,7 +11532,7 @@ proc have_host_locale { locale } { set locale [string map { "-" "" } $locale] set idx [lsearch [host_locales] $locale] - return [expr $idx != -1] + return [expr {$idx != -1}] } # Return 1 if we can use '#include <$file>' in source file. @@ -11062,7 +11560,7 @@ gdb_caching_proc root_user {} { regexp -all ".*uid=(\[0-9\]+).*" $output dummy uid - return [expr $uid == 0] + return [expr {$uid == 0}] } # Return nul-terminated string read from section SECTION of EXEC. Return "" @@ -11076,7 +11574,7 @@ proc section_get {exec section} { set command "exec $objcopy_program -O binary --set-section-flags $section=A --change-section-address $section=0 -j $section $exec $tmp" verbose -log "command is $command" - set result [catch $command output] + set result [catch {{*}$command} output] verbose -log "result is $result" verbose -log "output is $output" if {$result == 1} { @@ -11093,11 +11591,68 @@ proc section_get {exec section} { verbose -log "section $section not found" return "" } - set retval [string range $data 0 [expr $len - 1]] + set retval [string range $data 0 [expr {$len - 1}]] verbose -log "section $section is <$retval>" return $retval } +# Return true if we expect the build-id from FILENAME to be included +# in a core file. +# +# On GNU/Linux, when creating a core file, the kernel places the first +# page of an ELF into the core file. If the build-id is within that +# page then GDB can find the build-id from the core file. +# +# This proc checks that the target is GNU/Linux, and then uses readelf +# to find the offset of the build-id within the ELF. If there is a +# build-id, and it is within the first page, then return true. +# Otherwise, return false. + +proc expect_build_id_in_core_file { filename } { + # I'm not sure if other kernels take care to add the first page of + # each ELF into the core file. If they do then this test can be + # relaxed. + if {![istarget *-*-linux*]} { + return false + } + + # Use readelf to find the build-id note in FILENAME. + set readelf_program [gdb_find_readelf] + set cmd [list $readelf_program -WS $filename | grep ".note.gnu.build-id"] + set res [catch {exec {*}$cmd} output] + verbose -log "running: $cmd" + verbose -log "result: $res" + verbose -log "output: $output" + if { $res != 0 } { + return false + } + + # Extract the OFFSET from the readelf output. + set res [regexp {NOTE[ \t]+([0-9a-f]+)[ \t]+([0-9a-f]+)} \ + $output dummy addr offset] + if { $res != 1 } { + return false + } + + # Convert OFFSET to decimal. + set offset [expr {[subst 0x$offset]}] + + # Now figure out the page size. This should be fine for Linux + # hosts, see the istarget check above. + if {[catch {exec getconf PAGESIZE} page_size]} { + # Failed to fetch page size. + return false + } + + # If the build-id is within the first page, then we expect the + # kernel to include it in the core file. There is actually a + # kernel setting (see coredump_filter) that could prevent this, + # but the default behaviour is to include the first page of the + # ELF, so for now, we just assume this is on. + verbose -log "Page size is $page_size, Offset is $offset" + return [expr {$offset < $page_size}] +} + # Return 1 if the compiler supports __builtin_trap, else return 0. gdb_caching_proc have_builtin_trap {} { @@ -11110,5 +11665,46 @@ gdb_caching_proc have_builtin_trap {} { } executable] } +# Return 1 if there is a startup shell. Return -1 if there's no startup shell. +# Return -1 otherwise. + +gdb_caching_proc have_startup_shell {} { + if { [is_remote target] } { + # For remote debugging targets, there is no guarantee that a "shell" + # is used. + return -1 + } + + + gdb_exit + gdb_start + + set re_on \ + [string_to_regexp "Use of shell to start subprocesses is on."] + set re_off \ + [string_to_regexp "Use of shell to start subprocesses is off."] + set re_cmd_unsupported \ + [string_to_regexp \ + {Undefined show command: "startup-with-shell". Try "help show".}] + + set supported -1 + gdb_test_multiple "show startup-with-shell" "" { + -re -wrap $re_on { + set supported 1 + } + -re -wrap $re_off { + set supported 0 + } + -re -wrap $re_cmd_unsupported { + } + -re -wrap "" { + } + } + + gdb_exit + + return $supported +} + # Always load compatibility stuff. load_lib future.exp diff --git a/gdb/testsuite/lib/gdb_watchdog.h b/gdb/testsuite/lib/gdb_watchdog.h new file mode 100644 index 0000000..15d63e7 --- /dev/null +++ b/gdb/testsuite/lib/gdb_watchdog.h @@ -0,0 +1,75 @@ +/* This file is part of GDB, the GNU debugger. + + Copyright 2025 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/>. */ + +/* Set a watchdog that aborts the testcase after a timeout. */ + +#ifndef GDB_WATCHDOG_H +#define GDB_WATCHDOG_H + +/* Forward declaration to make sure the definitions have the right + prototype, at least in C. */ +static void gdb_watchdog (unsigned int seconds); + +static const char _gdb_watchdog_msg[] + = "gdb_watchdog: timeout expired - aborting test\n"; + +#ifdef _WIN32 +#include <windows.h> +#include <stdlib.h> +#include <stdio.h> + +static VOID CALLBACK +_gdb_watchdog_timer_routine (PVOID lpParam, BOOLEAN TimerOrWaitFired) +{ + fputs (_gdb_watchdog_msg, stderr); + abort (); +} + +static void +gdb_watchdog (unsigned int seconds) +{ + HANDLE timer; + + if (!CreateTimerQueueTimer (&timer, NULL, + _gdb_watchdog_timer_routine, NULL, + seconds * 1000, 0, 0)) + abort (); +} + +#else /* POSIX systems */ + +#include <unistd.h> +#include <signal.h> +#include <stdlib.h> + +static void +_gdb_sigalrm_handler (int signo) +{ + write (2, _gdb_watchdog_msg, sizeof (_gdb_watchdog_msg) - 1); + abort (); +} + +static void +gdb_watchdog (unsigned int seconds) +{ + signal (SIGALRM, _gdb_sigalrm_handler); + alarm (seconds); +} + +#endif + +#endif /* GDB_WATCHDOG_H */ diff --git a/gdb/testsuite/lib/gdbreplay-support.exp b/gdb/testsuite/lib/gdbreplay-support.exp index fc4dc52..2a43ede 100644 --- a/gdb/testsuite/lib/gdbreplay-support.exp +++ b/gdb/testsuite/lib/gdbreplay-support.exp @@ -45,7 +45,7 @@ proc gdbreplay_write_cmd_file { cmdline } { set logfile [standard_output_file_with_gdb_instance gdbreplay.cmd] set cmd_file [open $logfile w] puts $cmd_file $cmdline - catch "close $cmd_file" + catch {close $cmd_file} } # Start gdbreplay using REMOTELOG as the log file. Return a list of @@ -57,7 +57,7 @@ proc gdbreplay_start { remotelog } { set portnum [get_portnum] # Extract the protocol - if [target_info exists gdb_protocol] { + if {[target_info exists gdb_protocol]} { set protocol [target_info gdb_protocol] } else { set protocol "remote" @@ -115,29 +115,62 @@ proc gdbreplay_start { remotelog } { # # update_log $logname "${logname}.updated" "vMustReplyEmpty" "E.failed" -proc update_log { filename_in filename_out match_regexp newline } { +proc update_log { filename_in filename_out match_regexp newline truncate } { set fh_in [open $filename_in r] set fh_out [open $filename_out w] while { [gets $fh_in line] >= 0 } { # Print the line to the file. puts $fh_out $line - if { [regexp $match_regexp $line] } { - # print out NEWLINE. + + # If this line matches, then inject NEWLINE. + if { $match_regexp ne "" && [regexp $match_regexp $line] } { + # Print out NEWLINE. puts $fh_out "r +\$${newline}" - # Don't truncate the file, otherwise gdbreplay will - # close the connection early and this might impact - # what GDB does. We want GDB to get a chance to - # process the error. - puts $fh_out "c q" - puts $fh_out "w \$qTStatus#49" - puts $fh_out "End of log" + # Discard the line this just replaced. + gets $fh_in line - break + if { $truncate } { + # Don't truncate the file, otherwise gdbreplay will + # close the connection early and this might impact + # what GDB does. We want GDB to get a chance to + # process the error. + puts $fh_out "c q" + puts $fh_out "w \$qTStatus#49" + puts $fh_out "End of log" + + break + } + + # Clear MATCH_REGEXP so no further lines will match. + set match_regexp "" } } close $fh_out close $fh_in } + +# Return the line immediately after the first line in FILENAME that +# matches MATCH_REGEXP. If MATCH_REGEXP matches a packet sent from +# GDB to gdbserver, then the line returned should be the reply packet. +# +# If anything goes wrong, e.g. MATCH_REGEXP doesn't match anything, +# then an empty string is returned. + +proc get_reply_line { filename match_regexp } { + set fh_in [open $filename r] + set reply "" + + while { [gets $fh_in line] >= 0 } { + if { [regexp $match_regexp $line] } { + gets $fh_in reply + break + } + } + + close $fh_in + + return $reply +} diff --git a/gdb/testsuite/lib/gdbserver-support.exp b/gdb/testsuite/lib/gdbserver-support.exp index c285072..0652b35 100644 --- a/gdb/testsuite/lib/gdbserver-support.exp +++ b/gdb/testsuite/lib/gdbserver-support.exp @@ -30,7 +30,7 @@ # # set_board_info sockethost # The name of the host computer whose socket is being used. -# Defaults to "localhost". Note: old gdbserver requires +# Defaults to "localhost". Note: old gdbserver requires # that you define this, but libremote/gdbserver does not. # # set_board_info gdb,socketport @@ -69,7 +69,7 @@ proc gdb_target_cmd_ext { targetname serialport {additional_text ""} } { } -re "Non-stop mode requested, but remote does not support non-stop.*$gdb_prompt $" { verbose "remote does not support non-stop" - return 1 + return 2 } -re "Remote MIPS debugging.*$additional_text.*$gdb_prompt" { verbose "Set target to $targetname" @@ -125,8 +125,8 @@ proc gdb_target_cmd_ext { targetname serialport {additional_text ""} } { # Like gdb_target_cmd_ext, but returns 0 on success, 1 on failure. proc gdb_target_cmd { args } { - set res [eval gdb_target_cmd_ext $args] - return [expr $res == 0 ? 0 : 1] + set res [gdb_target_cmd_ext {*}$args] + return [expr {$res == 0 ? 0 : 1}] } # Return a usable port number. @@ -174,7 +174,7 @@ proc get_portnum {} { set portnum $initial_portnum } - set next_portnum [expr $portnum + 1] + set next_portnum [expr {$portnum + 1}] set fd [open $portnum_file w] puts $fd $next_portnum @@ -190,11 +190,11 @@ proc find_gdbserver { } { global GDB global GDBSERVER - if [info exists GDBSERVER] { + if {[info exists GDBSERVER]} { return ${GDBSERVER} } - if [target_info exists gdb_server_prog] { + if {[target_info exists gdb_server_prog]} { return [target_info gdb_server_prog] } @@ -315,7 +315,7 @@ proc gdbserver_start { options arguments } { # have the possible connection prefix stripped. This is # because gdbserver currently doesn't recognize the prefixes. regsub -all "^\(tcp:|udp:|tcp4:|udp4:|tcp6:|udp6:\)" $debughost_tmp "" debughost_gdbserver - } elseif [target_info exists sockethost] { + } elseif {[target_info exists sockethost]} { set debughost [target_info sockethost] set debughost_gdbserver $debughost } else { @@ -326,19 +326,19 @@ proc gdbserver_start { options arguments } { # Some boards use a different value for the port that is passed to # gdbserver and the port that is passed to the "target remote" command. # One example is the stdio gdbserver support. - if [target_info exists gdb,get_remote_address] { + if {[target_info exists gdb,get_remote_address]} { set get_remote_address [target_info gdb,get_remote_address] } else { set get_remote_address gdbserver_default_get_remote_address } - if [target_info exists gdbserver,get_comm_port] { + if {[target_info exists gdbserver,get_comm_port]} { set get_comm_port [target_info gdbserver,get_comm_port] } else { set get_comm_port gdbserver_default_get_comm_port } # Extract the protocol - if [target_info exists gdb_protocol] { + if {[target_info exists gdb_protocol]} { set protocol [target_info gdb_protocol] } else { set protocol "remote" @@ -362,7 +362,7 @@ proc gdbserver_start { options arguments } { } # Enable debug if set. - if [gdbserver_debug_enabled] { + if {[gdbserver_debug_enabled]} { global gdbserverdebug set enabled 0 foreach entry [split $gdbserverdebug ,] { @@ -490,13 +490,13 @@ proc close_gdbserver {} { verbose "Quitting GDBserver" - catch "close -i $server_spawn_id" + catch {close -i $server_spawn_id} # If gdbserver misbehaves, and ignores the close, waiting for it # without the -nowait flag will cause testing to hang. Passing # -nowait makes expect tell Tcl to wait for the process in the # background. - catch "wait -nowait -i $server_spawn_id" + catch {wait -nowait -i $server_spawn_id} clean_up_spawn_id target $server_spawn_id unset server_spawn_id } @@ -710,11 +710,11 @@ proc gdbserver_debug_enabled { } { global gdbserverdebug # If not already read, get the debug setting from environment or board setting. - if ![info exists gdbserverdebug] { + if {![info exists gdbserverdebug]} { global env - if [info exists env(GDBSERVER_DEBUG)] { + if {[info exists env(GDBSERVER_DEBUG)]} { set gdbserverdebug $env(GDBSERVER_DEBUG) - } elseif [target_info exists gdbserver,debug] { + } elseif {[target_info exists gdbserver,debug]} { set gdbserverdebug [target_info gdbserver,debug] } else { return 0 @@ -731,7 +731,7 @@ proc gdbserver_write_cmd_file { cmdline } { set logfile [standard_output_file_with_gdb_instance gdbserver.cmd] set cmd_file [open $logfile w] puts $cmd_file $cmdline - catch "close $cmd_file" + catch {close $cmd_file} } # Override gdb_debug_init so that we can set replay logging in GDB if required. @@ -743,7 +743,7 @@ proc gdb_debug_init { } { global gdbserverdebug global gdb_prompt - if [gdbserver_debug_enabled] { + if {[gdbserver_debug_enabled]} { foreach entry [split $gdbserverdebug ,] { if { $entry == "replay" || $entry == "all"} { set replayfile [standard_output_file_with_gdb_instance gdbserver.replay] diff --git a/gdb/testsuite/lib/gen-perf-test.exp b/gdb/testsuite/lib/gen-perf-test.exp index dbdc79b..feee2db 100644 --- a/gdb/testsuite/lib/gen-perf-test.exp +++ b/gdb/testsuite/lib/gen-perf-test.exp @@ -51,12 +51,12 @@ # not clear that's simpler than our chosen mechanism which is to record # sums of all the inputs, and detect if an input has changed that way. -if ![info exists CAT_PROGRAM] { +if {![info exists CAT_PROGRAM]} { set CAT_PROGRAM "/bin/cat" } # TODO(dje): Time md5sum vs sha1sum with our testcases. -if ![info exists SHA1SUM_PROGRAM] { +if {![info exists SHA1SUM_PROGRAM]} { set SHA1SUM_PROGRAM "/usr/bin/sha1sum" } @@ -295,7 +295,7 @@ namespace eval GenPerfTest { } set values $self($p) for { set i 0 } { $i < $n - 1 } { incr i } { - if { [lindex $values $i] > [lindex $values [expr $i + 1]] } { + if { [lindex $values $i] > [lindex $values [expr {$i + 1}]] } { error "Values of parameter $p are not increasing" } } @@ -322,7 +322,7 @@ namespace eval GenPerfTest { nr_methods - nr_static_methods - nr_inline_methods - nr_static_inline_methods { - if ![string is integer $value] { + if {![string is integer $value]} { error "Non-integer value $value for key $key in class_specs: $class_specs" } } @@ -397,7 +397,7 @@ namespace eval GenPerfTest { proc _classes_enabled_p { self_var run_nr } { upvar 1 $self_var self set class_specs [_get_param $self(class_specs) $run_nr] - return [expr [llength $class_specs] > 0] + return [expr {[llength $class_specs] > 0}] } # Spaces in file names are a pain, remove them. @@ -428,7 +428,7 @@ namespace eval GenPerfTest { # description file. set bindir [file dirname $self(binfile)] # Put the pieces in a subdirectory, there are a lot of them. - if $static { + if {$static} { return "$bindir/pieces" } else { set run_name [_convert_spaces [lindex $self(run_names) $run_nr]] @@ -691,7 +691,7 @@ namespace eval GenPerfTest { # C is the iteration number, from the "count" field from the class spec. proc _make_class_name { so_nr cu_nr name c } { - set class_name [lindex $name [expr [llength $name] - 1]] + set class_name [lindex $name [expr {[llength $name] - 1}]] if { "$so_nr" != "" } { set prefix "shlib${so_nr}_" } else { @@ -717,7 +717,7 @@ namespace eval GenPerfTest { set nr_static_members [_get_class_spec $spec nr_static_members] set nr_methods [_get_class_spec $spec nr_methods] set nr_static_methods [_get_class_spec $spec nr_static_methods] - set depth [expr [llength $name] - 1] + set depth [expr {[llength $name] - 1}] for { set c 0 } { $c < $count } { incr c } { puts $f "" for { set i 0 } { $i < $depth } { incr i } { @@ -750,7 +750,7 @@ namespace eval GenPerfTest { _write_inline_methods self $f $so_nr $cu_nr $spec $c _write_static_inline_methods self $f $so_nr $cu_nr $spec $c puts $f "\};" - for { set i [expr $depth - 1] } { $i >= 0 } { incr i -1 } { + for { set i [expr {$depth - 1}] } { $i >= 0 } { incr i -1 } { puts $f "" puts $f "\} // [lindex $name $i]" } @@ -782,7 +782,7 @@ namespace eval GenPerfTest { foreach spec $class_specs { set count [_get_class_spec $spec count] set name [_get_class_spec $spec name] - set depth [expr [llength $name] - 1] + set depth [expr {[llength $name] - 1}] for { set c 0 } { $c < $count } { incr c } { for { set i 0 } { $i < $depth } { incr i } { puts $f "" @@ -792,7 +792,7 @@ namespace eval GenPerfTest { _write_static_members self $f $so_nr $cu_nr $spec $c _write_methods self $f $so_nr $cu_nr $spec $c _write_static_methods self $f $so_nr $cu_nr $spec $c - for { set i [expr $depth - 1] } { $i >= 0 } { incr i -1 } { + for { set i [expr {$depth - 1}] } { $i >= 0 } { incr i -1 } { puts $f "" puts $f "\} // [lindex $name $i]" } @@ -854,7 +854,7 @@ namespace eval GenPerfTest { puts $f "" puts $f "#ifndef $header_macro" puts $f "#define $header_macro" - if [_classes_enabled_p self $run_nr] { + if {[_classes_enabled_p self $run_nr]} { _write_class_definitions self $f $static $run_nr $so_nr $cu_nr } puts $f "" @@ -875,7 +875,7 @@ namespace eval GenPerfTest { _write_extern_globals self $f $run_nr "" $cu_nr _write_static_functions self $f $run_nr _write_extern_functions self $f $run_nr "" $cu_nr - if [_classes_enabled_p self $run_nr] { + if {[_classes_enabled_p self $run_nr]} { _write_class_implementations self $f $static $run_nr "" $cu_nr } close $f @@ -917,7 +917,7 @@ namespace eval GenPerfTest { _write_extern_globals self $f $run_nr "shlib${so_nr}_" $cu_nr _write_static_functions self $f $run_nr _write_extern_functions self $f $run_nr "shlib${so_nr}_" $cu_nr - if [_classes_enabled_p self $run_nr] { + if {[_classes_enabled_p self $run_nr]} { _write_class_implementations self $f $static $run_nr $so_nr $cu_nr } close $f @@ -998,8 +998,8 @@ namespace eval GenPerfTest { set vars { CC_FOR_TARGET CXX_FOR_TARGET CFLAGS_FOR_TARGET } foreach v $vars { global $v - if [info exists $v] { - eval set value $$v + if {[info exists $v]} { + set value [subst $$v] puts $f "$v: $value" } } @@ -1049,7 +1049,7 @@ namespace eval GenPerfTest { } } verbose -log "_gen_sha1sum_for_inputs: summing $source_files $header_paths $inputs" - set catch_result [catch "exec $CAT_PROGRAM $source_files $header_paths $inputs | $SHA1SUM_PROGRAM" output] + set catch_result [catch {exec $CAT_PROGRAM $source_files $header_paths $inputs | $SHA1SUM_PROGRAM} output] return [list $catch_result $output] } @@ -1100,10 +1100,10 @@ namespace eval GenPerfTest { return "sha1sum generation error: [lindex $sha1sum 1]" } set sha1sum [lindex $sha1sum 1] - if ![file exists $dest] { + if {![file exists $dest]} { file delete $sha1sum_file } - if [file exists $sha1sum_file] { + if {[file exists $sha1sum_file]} { set last_sha1sum [_read_file $sha1sum_file] verbose -log "last: $last_sha1sum, new: $sha1sum" if { $sha1sum == $last_sha1sum } { @@ -1234,10 +1234,10 @@ namespace eval GenPerfTest { set static [_static_object_files_p self] verbose -log "_compile_pieces: static flag: $static" file mkdir "[file dirname $self(binfile)]/pieces" - if $static { + if {$static} { # All the generated pieces look the same (run over run) so just # build all the shlibs of the last run (which is the largest). - set last_run [expr $nr_runs - 1] + set last_run [expr {$nr_runs - 1}] set nr_gen_shlibs [_get_param $self(nr_gen_shlibs) $last_run] set object_dir [_make_object_dir_name self $static ignored] file mkdir $object_dir @@ -1412,7 +1412,7 @@ namespace eval GenPerfTest { proc standard_compile_driver { exp_file_name make_config_thunk_name } { global GDB_PERFTEST_MODE GDB_PERFTEST_SUBMODE - if ![info exists GDB_PERFTEST_SUBMODE] { + if {![info exists GDB_PERFTEST_SUBMODE]} { # Probably a plain "make check-perf", nothing to do. # Give the user a reason why we're not running this test. verbose -log "Test must be compiled/run in separate steps." @@ -1504,6 +1504,6 @@ namespace eval GenPerfTest { } } -if ![info exists PERF_TEST_COMPILE_PARALLELISM] { +if {![info exists PERF_TEST_COMPILE_PARALLELISM]} { set PERF_TEST_COMPILE_PARALLELISM $GenPerfTest::DEFAULT_PERF_TEST_COMPILE_PARALLELISM } diff --git a/gdb/testsuite/lib/go.exp b/gdb/testsuite/lib/go.exp index 5f668e2..dcf7ffa 100644 --- a/gdb/testsuite/lib/go.exp +++ b/gdb/testsuite/lib/go.exp @@ -20,11 +20,12 @@ # The result is 1 (true) for success, 0 (false) for failure. proc set_lang_go {} { - if [gdb_test_no_output "set language go"] { + if {[gdb_test_no_output "set language go"]} { return 0 } - if [gdb_test "show language" ".* source language is \"go\"." \ - "set language to \"go\""] { + if {[gdb_test "show language" \ + [string_to_regexp {The current source language is "go".}] \ + {set language to "go"}]} { return 0 } return 1 diff --git a/gdb/testsuite/lib/jit-elf-helpers.exp b/gdb/testsuite/lib/jit-elf-helpers.exp index e5c328e..1f0a0d2 100644 --- a/gdb/testsuite/lib/jit-elf-helpers.exp +++ b/gdb/testsuite/lib/jit-elf-helpers.exp @@ -91,7 +91,7 @@ proc compile_and_download_n_jit_so {jit_solib_basename jit_solib_srcfile \ # do symbol renaming by munging on ELF symbol table, and that # wouldn't work for .debug sections. Also, output for "info # function" changes when debug info is present. - set addr [format 0x%x [expr $jit_load_address + $jit_load_increment * [expr $i-1]]] + set addr [format 0x%x [expr {$jit_load_address + $jit_load_increment * ($i - 1)}]] # Use "text_segment=..." to ask the linker to relocate everything in the # compiled shared library against a fixed base address. Combined diff --git a/gdb/testsuite/lib/mi-support.exp b/gdb/testsuite/lib/mi-support.exp index aba13a2..eac9c47 100644 --- a/gdb/testsuite/lib/mi-support.exp +++ b/gdb/testsuite/lib/mi-support.exp @@ -65,7 +65,7 @@ proc mi_uncatched_gdb_exit {} { sid_exit } - if ![info exists gdb_spawn_id] { + if {![info exists gdb_spawn_id]} { return } @@ -99,7 +99,7 @@ proc mi_uncatched_gdb_exit {} { close -i $mi_spawn_id } - if ![is_remote host] { + if {![is_remote host]} { remote_close host } unset gdb_spawn_id @@ -256,7 +256,7 @@ proc default_mi_gdb_start { { flags {} } } { sid_start } - if [info exists gdb_spawn_id] { + if {[info exists gdb_spawn_id]} { return 0 } @@ -340,12 +340,12 @@ proc default_mi_gdb_start { { flags {} } } { # baseboard file. # proc mi_gdb_start { args } { - return [eval default_mi_gdb_start $args] + return [default_mi_gdb_start {*}$args] } # Many of the tests depend on setting breakpoints at various places and # running until that breakpoint is reached. At times, we want to start -# with a clean-slate with respect to breakpoints, so this utility proc +# with a clean-slate with respect to breakpoints, so this utility proc # lets us do this without duplicating this code everywhere. # @@ -386,7 +386,7 @@ proc mi_gdb_reinitialize_dir { subdir } { global mi_gdb_prompt global MIFLAGS - if [is_remote host] { + if {[is_remote host]} { return "" } @@ -487,7 +487,7 @@ proc mi_gdb_file_cmd { arg } { set last_loaded_file $arg - if [is_remote host] { + if {[is_remote host]} { set arg [remote_download host $arg] if { $arg == "" } { error "download failed" @@ -553,7 +553,7 @@ proc mi_gdb_target_load { } { global GDB global mi_gdb_prompt - if [target_info exists gdb_load_timeout] { + if {[target_info exists gdb_load_timeout]} { set loadtimeout [target_info gdb_load_timeout] } else { set loadtimeout 1600 @@ -700,11 +700,11 @@ proc mi_gdb_test { args } { set message $command } - if [llength $args]==4 { + if {[llength $args] == 4} { set ipattern [lindex $args 3] } - if [llength $args]==5 { + if {[llength $args] == 5} { set question_string [lindex $args 3] set response_string [lindex $args 4] } else { @@ -729,7 +729,7 @@ proc mi_gdb_test { args } { while { "$string" != "" } { set foo [string first "\n" "$string"] set len [string length "$string"] - if { $foo < [expr $len - 1] } { + if {$foo < $len - 1} { set str [string range "$string" 0 $foo] if { [send_gdb "$str"] != "" } { perror "Couldn't send $command to GDB." @@ -738,7 +738,7 @@ proc mi_gdb_test { args } { -re "\[\r\n\]" { } timeout { } } - set string [string range "$string" [expr $foo + 1] end] + set string [string range "$string" [expr {$foo + 1}] end] } else { break } @@ -750,11 +750,11 @@ proc mi_gdb_test { args } { } } - if [info exists timeout] { + if {[info exists timeout]} { set tmt $timeout } else { global timeout - if [info exists timeout] { + if {[info exists timeout]} { set tmt $timeout } else { set tmt 60 @@ -786,13 +786,13 @@ proc mi_gdb_test { args } { # and $expect_out(2,string) is the MI output command. # If $expect_out(1,string) is "", then there was no MI input command here. - # NOTE, there is no trailing anchor because with GDB/MI, - # asynchronous responses can happen at any point, causing more - # data to be available. Normally an anchor is used to make - # sure the end of the output is matched, however, $mi_gdb_prompt - # is just as good of an anchor since mi_gdb_test is meant to - # match a single mi output command. If a second GDB/MI output - # response is sent, it will be in the buffer for the next + # NOTE, there is no trailing anchor because with GDB/MI, + # asynchronous responses can happen at any point, causing more + # data to be available. Normally an anchor is used to make + # sure the end of the output is matched, however, $mi_gdb_prompt + # is just as good of an anchor since mi_gdb_test is meant to + # match a single mi output command. If a second GDB/MI output + # response is sent, it will be in the buffer for the next # time mi_gdb_test is called. if {![string match "" $message]} { pass "$message" @@ -863,7 +863,7 @@ proc mi_gdb_test { args } { # If the GDB output matched, compare the inferior output. if { $result == 0 } { - if [ info exists ipattern ] { + if {[ info exists ipattern ]} { if { ![target_info exists gdb,noinferiorio] } { global gdb_spawn_id inferior_spawn_id @@ -957,8 +957,8 @@ proc mi_run_cmd_full {use_mi_command args} { return -1 } - if $use_gdb_stub { - if [target_info exists gdb,do_reload_on_run] { + if {$use_gdb_stub} { + if {[target_info exists gdb,do_reload_on_run]} { send_gdb "${run_prefix}continue\n" gdb_expect 60 { -re "${run_match}\\^running\[\r\n\]+\\*running,thread-id=\"\[^\"\]+\"\r\n$mi_gdb_prompt" {} @@ -968,7 +968,7 @@ proc mi_run_cmd_full {use_mi_command args} { return 0 } - if [target_info exists gdb,start_symbol] { + if {[target_info exists gdb,start_symbol]} { set start [target_info gdb,start_symbol] } else { set start "start" @@ -1010,14 +1010,14 @@ proc mi_run_cmd_full {use_mi_command args} { # -exec-continue, as appropriate. ARGS are passed verbatim to # mi_run_cmd_full. proc mi_run_cmd {args} { - return [eval mi_run_cmd_full 1 $args] + return [mi_run_cmd_full 1 {*}$args] } # A wrapper for mi_run_cmd_full which uses the CLI commands 'run' and # 'continue', as appropriate. ARGS are passed verbatim to # mi_run_cmd_full. proc mi_run_with_cli {args} { - return [eval mi_run_cmd_full 0 $args] + return [mi_run_cmd_full 0 {*}$args] } # Starts fresh GDB binary and loads an optional executable into GDB. @@ -1044,6 +1044,9 @@ proc mi_clean_restart {{executable ""} {flags {}}} { mi_gdb_reinitialize_dir $srcdir/$subdir if {$executable != ""} { + if { [file pathtype $executable] == "absolute" } { + error "absolute path used" + } set binfile [standard_output_file ${executable}] return [mi_gdb_load ${binfile}] } @@ -1285,7 +1288,7 @@ proc mi_expect_stop { reason func args file line extra test } { set r "reason=$reason," } else { set r "reason=\"$reason\"," - } + } } @@ -1394,7 +1397,7 @@ proc mi_continue_to {func} { # returns the breakpoint regexp from that procedure. proc mi_create_breakpoint {location test args} { - set bp [eval mi_make_breakpoint $args] + set bp [mi_make_breakpoint {*}$args] mi_gdb_test "222-break-insert $location" "222\\^done,$bp" $test return $bp } @@ -1403,7 +1406,7 @@ proc mi_create_breakpoint {location test args} { # locations using mi_make_breakpoint_multi instead. proc mi_create_breakpoint_multi {location test args} { - set bp [eval mi_make_breakpoint_multi $args] + set bp [mi_make_breakpoint_multi {*}$args] mi_gdb_test "222-break-insert $location" "222\\^done,$bp" $test return $bp } @@ -1411,7 +1414,7 @@ proc mi_create_breakpoint_multi {location test args} { # Like mi_create_breakpoint, but creates a pending breakpoint. proc mi_create_breakpoint_pending {location test args} { - set bp [eval mi_make_breakpoint_pending $args] + set bp [mi_make_breakpoint_pending {*}$args] mi_gdb_test "222-break-insert $location" ".*\r\n222\\^done,$bp" $test return $bp } @@ -1706,16 +1709,16 @@ proc mi_prepare_inline_tests { filename } { set prefix [string range $content 0 $start] set prefix_newlines [count_newlines $prefix] - set line_number [expr $line_number+$prefix_newlines] + set line_number [expr {$line_number+$prefix_newlines}] set comment_line $line_number - set comment [string range $content [expr $start+3] [expr $end-1]] + set comment [string range $content [expr {$start+3}] [expr {$end-1}]] set comment_newlines [count_newlines $comment] - set line_number [expr $line_number+$comment_newlines] + set line_number [expr {$line_number+$comment_newlines}] set comment [string trim $comment] - set content [string range $content [expr $end+3] \ + set content [string range $content [expr {$end+3}] \ [string length $content]] lappend mi_autotest_data [list $comment $comment_line] } else { @@ -1907,7 +1910,7 @@ proc mi_run_inline_test { testcase } { foreach c $commands { set statements [lindex $c 0] set line [lindex $c 1] - set line [expr $line-1] + set line [expr {$line-1}] # We want gdb to be stopped at the expression immediately # before the comment. If this is the first comment, the @@ -1946,6 +1949,7 @@ proc mi_run_inline_test { testcase } { # have direct access to global variables that the # main 'exp' file has set up. But it's not yet clear, # will need more experience to be sure. + # tclint-disable-next-line command-args eval $statements } @@ -2004,7 +2008,7 @@ proc check_mi_and_console_threads_1 { name } { # GDB will return a list of thread ids and some more info: # - # (gdb) + # (gdb) # -interpreter-exec console "info threads" # ~" 4 Thread 2051 (LWP 7734) 0x401166b1 in __libc_nanosleep () at __libc_nanosleep:-1" # ~" 3 Thread 1026 (LWP 7733) () at __libc_nanosleep:-1" @@ -2099,7 +2103,7 @@ proc check_mi_and_console_threads { name } { proc mi_locate_shlib { file } { global mi_spawn_id - if ![info exists mi_spawn_id] { + if {![info exists mi_spawn_id]} { perror "mi_locate_shlib: GDB is not running" } @@ -2279,19 +2283,23 @@ namespace eval ::varobj_tree { proc mi_varobj_tree_dump_variable {variable_name {cmd send_log} {term "\n"}} { upvar #0 $variable_name varobj + # tclint-disable-next-line command-args eval "$cmd \"VAR = $variable_name$term\"" # Explicitly encode the array indices, since outputting them # in some logical order is better than what "array names" might # return. foreach idx {obj_name parent display_name type path_expr} { + # tclint-disable-next-line command-args eval "$cmd \"\t$idx = $varobj($idx)$term\"" } # Output children set num [llength $varobj(children)] + # tclint-disable-next-line command-args eval "$cmd \"\tnum_children = $num$term\"" if {$num > 0} { + # tclint-disable-next-line command-args eval "$cmd \"\tchildren = $varobj(children)$term\"" } } @@ -2683,7 +2691,7 @@ proc mi_make_info_frame_regexp {args} { proc mi_info_frame { test args } { parse_some_args {{frame ""} {thread ""}} - set re [eval mi_make_info_frame_regexp $args] + set re [mi_make_info_frame_regexp {*}$args] set cmd "235-stack-info-frame" if {$frame ne ""} { @@ -2919,7 +2927,7 @@ proc mi_get_valueof { fmt exp default {test ""} } { proc foreach_mi_ui_mode { var_name body } { upvar 1 $var_name var - if [gdb_debug_enabled] { + if {[gdb_debug_enabled]} { # gdb debug doesn't work for separate-mi-tty. set modes {"main"} } else { diff --git a/gdb/testsuite/lib/objc.exp b/gdb/testsuite/lib/objc.exp index cf1fed9..cb59ca1 100644 --- a/gdb/testsuite/lib/objc.exp +++ b/gdb/testsuite/lib/objc.exp @@ -19,11 +19,12 @@ # The result is 1 (true) for success, 0 (false) for failure. proc set_lang_objc {} { - if [gdb_test_no_output "set language objective-c"] { + if {[gdb_test_no_output "set language objective-c"]} { return 0 } - if [gdb_test "show language" ".* source language is \"objective-c\"." \ - "set language to \"objective-c\""] { + if {[gdb_test "show language" \ + [string_to_regexp {The current source language is "objective-c".}] \ + {set language to "objective-c"}]} { return 0 } return 1 diff --git a/gdb/testsuite/lib/pascal.exp b/gdb/testsuite/lib/pascal.exp index d76cdca..12f8a2f 100644 --- a/gdb/testsuite/lib/pascal.exp +++ b/gdb/testsuite/lib/pascal.exp @@ -26,11 +26,11 @@ set pascal_init_done 0 # Second, environment variable FPC is checked # if present, Free Pascal compiler is assumed to be the value of # that environment variable. -# Third, gpc executable is searched using `which gpc` -# Lastly, fpc executable is searched using `which fpc` +# Third, gpc executable is searched using `which gpc` +# Lastly, fpc executable is searched using `which fpc` # Using environment variable allows to force # which compiler is used in testsuite - + proc pascal_init {} { global pascal_init_done gdb_persistent_global pascal_compiler_is_gpc @@ -38,7 +38,7 @@ proc pascal_init {} { gdb_persistent_global gpc_compiler gdb_persistent_global fpc_compiler global env - + if { $pascal_init_done == 1 } { return } @@ -48,7 +48,7 @@ proc pascal_init {} { set gpc_compiler [transform gpc] set fpc_compiler [transform fpc] - if ![is_remote host] { + if {![is_remote host]} { if { [info exists env(GPC)] } { set pascal_compiler_is_gpc 1 set gpc_compiler $env(GPC) @@ -66,7 +66,7 @@ proc pascal_init {} { } } set pascal_init_done 1 -} +} proc gpc_compile {source destfile type options} { global gpc_compiler @@ -80,21 +80,21 @@ proc gpc_compile {source destfile type options} { if { $type == "preprocess" } { append add_flags " -E" } - + if { $type == "assembly" } { append add_flags " -S" } foreach i $options { if { $i == "debug" } { - if [board_info $dest exists debug_flags] { + if {[board_info $dest exists debug_flags]} { append add_flags " [board_info $dest debug_flags]" } else { append add_flags " -g" } } if { $i == "class" } { - if [board_info $dest exists pascal_class_flags] { + if {[board_info $dest exists pascal_class_flags]} { append add_flags " [board_info $dest pascal_class_flags]" } else { append add_flags " --extended-syntax" @@ -118,21 +118,21 @@ proc fpc_compile {source destfile type options} { if { $type == "preprocess" } { return "Free Pascal can not preprocess" } - + if { $type == "assembly" } { append add_flags " -al" } foreach i $options { if { $i == "debug" } { - if [board_info $dest exists debug_flags] { + if {[board_info $dest exists debug_flags]} { append add_flags " [board_info $dest debug_flags]" } else { append add_flags " -g" } } if { $i == "class" } { - if [board_info $dest exists pascal_class_flags] { + if {[board_info $dest exists pascal_class_flags]} { append add_flags " [board_info $dest pascal_class_flags]" } else { append add_flags " -Mobjfpc" @@ -149,7 +149,7 @@ proc gdb_compile_pascal {source destfile type options} { global pascal_compiler_is_gpc global pascal_compiler_is_fpc - if { $pascal_init_done == 0 } { + if { $pascal_init_done == 0 } { pascal_init } @@ -164,7 +164,7 @@ proc gdb_compile_pascal {source destfile type options} { return "No pascal compiler. Compilation failed." } - if ![file exists $destfile] { + if {![file exists $destfile]} { unsupported "Pascal compilation failed: $result" return "Pascal compilation failed." } @@ -174,11 +174,12 @@ proc gdb_compile_pascal {source destfile type options} { # The result is 1 (true) for success, 0 (false) for failure. proc set_lang_pascal {} { - if [gdb_test_no_output "set language pascal"] { + if {[gdb_test_no_output "set language pascal"]} { return 0 } - if [gdb_test "show language" ".* source language is \"pascal\"." \ - "set language to \"pascal\""] { + if {[gdb_test "show language" \ + [string_to_regexp {The current source language is "pascal".}] \ + {set language to "pascal"}]} { return 0 } return 1 diff --git a/gdb/testsuite/lib/perftest.exp b/gdb/testsuite/lib/perftest.exp index cca0ede..68022f9 100644 --- a/gdb/testsuite/lib/perftest.exp +++ b/gdb/testsuite/lib/perftest.exp @@ -90,11 +90,12 @@ namespace eval PerfTest { proc assemble {compile startup run} { global GDB_PERFTEST_MODE - if ![info exists GDB_PERFTEST_MODE] { + if {![info exists GDB_PERFTEST_MODE]} { return } if { [string compare $GDB_PERFTEST_MODE "run"] != 0 } { + # tclint-disable-next-line command-args if { [eval compile {$compile}] } { untested "failed to compile" return @@ -108,7 +109,8 @@ namespace eval PerfTest { verbose -log "PerfTest::assemble, startup ..." - if [eval startup {$startup}] { + # tclint-disable-next-line command-args + if {[eval startup {$startup}]} { fail "startup" return } @@ -119,7 +121,8 @@ namespace eval PerfTest { verbose -log "PerfTest::assemble, run ..." - if [eval run {$run}] { + # tclint-disable-next-line command-args + if {[eval run {$run}]} { fail "run" } @@ -134,7 +137,7 @@ namespace eval PerfTest { proc allow_perf_tests { } { global GDB_PERFTEST_MODE - if [info exists GDB_PERFTEST_MODE] { + if {[info exists GDB_PERFTEST_MODE]} { if { "$GDB_PERFTEST_MODE" != "compile" && "$GDB_PERFTEST_MODE" != "run" && "$GDB_PERFTEST_MODE" != "both" } { diff --git a/gdb/testsuite/lib/prelink-support.exp b/gdb/testsuite/lib/prelink-support.exp index a712a7a..beadd61 100644 --- a/gdb/testsuite/lib/prelink-support.exp +++ b/gdb/testsuite/lib/prelink-support.exp @@ -27,7 +27,7 @@ proc symlink_resolve {file} { verbose -log "Resolved symlink $file targeting $target as $src2" set file $src2 - set loop [expr $loop + 1] + set loop [expr {$loop + 1}] if {$loop > 30} { fail "looping symlink resolution for $file" return "" @@ -49,7 +49,7 @@ proc file_copy {src dest} { set test "copy [file tail $src] to [file tail $dest]" set command "file copy -force -- $src $dest" verbose -log "command is $command" - if [catch $command] { + if {[catch {{*}$command}]} { fail $test return 0 } else { @@ -99,7 +99,7 @@ proc build_executable_own_libs {testname executable sources options {interp ""} set ldd [gdb_find_ldd] set command "$ldd $binfile" set test "ldd $executable" - set result [catch "exec $command" output] + set result [catch {exec {*}$command} output] verbose -log "result of $command is $result" verbose -log "output of $command is $output" if {$result != 0 || $output == ""} { @@ -173,7 +173,7 @@ proc prelink_no {arg {name {}}} { set test "unprelink $name" set command "exec /usr/sbin/prelink -uN $arg" verbose -log "command is $command" - set result [catch $command output] + set result [catch {{*}$command} output] verbose -log "result is $result" verbose -log "output is $output" if {$result == 1 && [regexp {^(couldn't execute "/usr/sbin/prelink[^\r\n]*": no such file or directory\n?)*$} $output]} { @@ -182,14 +182,14 @@ proc prelink_no {arg {name {}}} { # have already been prelinked). set test "$test (missing /usr/sbin/prelink)" foreach bin [split $arg] { - if [string match "-*" $bin] { + if {[string match "-*" $bin]} { # Skip prelink options. continue } set readelf_program [gdb_find_readelf] set command "exec $readelf_program -WS $bin" verbose -log "command is $command" - set result [catch $command output] + set result [catch {{*}$command} output] verbose -log "result is $result" verbose -log "output is $output" if {$result != 0 || [string match {* .gnu.prelink_undo *} $output]} { @@ -204,7 +204,7 @@ proc prelink_no {arg {name {}}} { verbose -log "$name has been now unprelinked" set command "exec /usr/sbin/prelink -uN $arg" verbose -log "command is $command" - set result [catch $command output] + set result [catch {{*}$command} output] verbose -log "result is $result" verbose -log "output is $output" } @@ -230,7 +230,7 @@ proc prelink_yes {arg {name ""}} { # Try to unprelink it first so that, if it has been already prelinked # before, we get a different address now, making the new result unaffected # by any previous prelinking. - if ![prelink_no $arg "$name pre-unprelink"] { + if {![prelink_no $arg "$name pre-unprelink"]} { return 0 } @@ -251,7 +251,7 @@ proc prelink_yes {arg {name ""}} { set command "exec /usr/sbin/prelink -qNR --no-exec-shield $arg" verbose -log "command is $command" - set result [catch $command output] + set result [catch {{*}$command} output] verbose -log "result is $result" verbose -log "output is $output" if {$result == 1 && [regexp {^(couldn't execute "/usr/sbin/prelink[^\r\n]*": no such file or directory\n?)*$} $output]} { diff --git a/gdb/testsuite/lib/prompt.exp b/gdb/testsuite/lib/prompt.exp index 7fa131b..0473d69 100644 --- a/gdb/testsuite/lib/prompt.exp +++ b/gdb/testsuite/lib/prompt.exp @@ -44,11 +44,11 @@ proc default_prompt_gdb_start { } { verbose "Spawning $GDB $INTERNAL_GDBFLAGS $GDBFLAGS" gdb_write_cmd_file "$GDB $INTERNAL_GDBFLAGS $GDBFLAGS" - if [info exists gdb_spawn_id] { + if {[info exists gdb_spawn_id]} { return 0 } - if ![is_remote host] { + if {![is_remote host]} { if {[which $GDB] == 0} { perror "$GDB does not exist." exit 1 diff --git a/gdb/testsuite/lib/rust-support.exp b/gdb/testsuite/lib/rust-support.exp index 94888e9..7087e82 100644 --- a/gdb/testsuite/lib/rust-support.exp +++ b/gdb/testsuite/lib/rust-support.exp @@ -16,11 +16,12 @@ # Auxiliary function to set the language to Rust. # The result is 1 (true) for success, 0 (false) for failure. proc set_lang_rust {} { - if [gdb_test_no_output "set language rust"] { + if {[gdb_test_no_output "set language rust"]} { return 0 } - if [gdb_test "show language" ".* source language is \"rust\"." \ - "set language to \"rust\""] { + if {[gdb_test "show language" \ + [string_to_regexp {The current source language is "rust".}] \ + {set language to "rust"}]} { return 0 } return 1 diff --git a/gdb/testsuite/lib/selftest-support.exp b/gdb/testsuite/lib/selftest-support.exp index e037664..d0905eb 100644 --- a/gdb/testsuite/lib/selftest-support.exp +++ b/gdb/testsuite/lib/selftest-support.exp @@ -16,7 +16,7 @@ # Find a pathname to a file that we would execute if the shell was asked # to run $arg using the current PATH. -proc find_gdb { arg } { +proc _selftest_find_gdb { arg } { # If the arg directly specifies an existing executable file, then # simply use it. @@ -36,65 +36,163 @@ proc find_gdb { arg } { return $arg } -# A helper proc that sets up for self-testing. -# EXECUTABLE is the gdb to use. -# FUNCTION is the function to break in, either captured_main -# or captured_command_loop. -# Return 0 in case of success, -1 in case of failure, and -2 in case of -# skipping the test-case. +# Return true if the GDB under test is installed (as opposed to a GDB in its +# build directory). -proc selftest_setup { executable function } { - global gdb_prompt - global INTERNAL_GDBFLAGS +proc _selftest_gdb_is_installed {} { + # If GDB_DATA_DIRECTORY is empty, assume that it is an installed GDB. It is + # not a perfectly accurate check, but should be good enough. + return [expr {"$::GDB_DATA_DIRECTORY" == ""}] +} + +# Return true if the libtool binary is present on the host. + +proc _selftest_has_libtool {} { + lassign [remote_exec host "sh -c \"command -v libtool\""] status output + return [expr {$status == 0}] +} + +# If GDB is executed from a build tree, run libtool to obtain the real +# executable path for EXECUTABLE, which may be a libtool wrapper. Return +# the path on success. On failure, issue an UNTESTED test result and return +# an empty string. +# +# If GDB is executed from an installed location, return EXECUTABLE unchanged. +# +# If libtool is not present on the host system, return EXECUTABLE unchanged. +# The test might still work, because the GDB binary is not always a libtool +# wrapper. + +proc selftest_libtool_get_real_gdb_executable { executable } { + if {[_selftest_gdb_is_installed]} { + return $executable + } - # load yourself into the debugger + if {![_selftest_has_libtool]} { + return $executable + } + + lassign [remote_exec host libtool "--mode=execute echo -n $executable"] \ + status executable + + if { $status != 0 } { + untested "failed to run libtool" + return "" + } - global gdb_file_cmd_debug_info - set gdb_file_cmd_debug_info "unset" + return $executable +} + +# Return true if EXECUTABLE has debug info. +# +# If it doesn't, or if it's not possible to determine, issue an UNTESTED test +# result and return false. + +proc _selftest_check_executable_debug_info { executable } { + set ::gdb_file_cmd_debug_info "unset" + set result true + + # On Cygwin (at least), gdb/gdb.exe is a libtool wrapper (which happens to + # be a PE executable). The real binary is gdb/.libs/gdb.exe. If we load + # gdb/gdb.exe, we won't see any debug info and conclude that we can't run + # the test. Obtain the real executable path using libtool. + # + # At the time of writing, we don't see a libtool wrapper generated on Linux. + # But if there was one, it would be a shell script, and it would not be + # possible to load it in gdb. This conversion would therefore also be + # necessary. + # + # If testing against an installed GDB, then there won't be a libtool + # wrapper, no need to convert. + set executable [selftest_libtool_get_real_gdb_executable $executable] + + if { $executable == "" } { + # selftest_libtool_get_real_gdb_executable already records an UNTESTED + # on failure. + return false + } - set result [gdb_load $executable] + gdb_start - if {$result != 0} { - return -1 + if {[gdb_load $executable] != 0} { + untested "failed to load executable when checking for debug info" + set result false } - if {$gdb_file_cmd_debug_info != "debug"} { + if {$::gdb_file_cmd_debug_info != "debug"} { untested "no debug information, skipping testcase." - return -2 + set result false } - # Set a breakpoint at $function. + gdb_exit + + return $result +} + +# A helper proc that sets up for self-testing. +# +# Assumes that the inferior GDB is already loaded in the top-level GDB. +# +# Return 0 in case of success, -1 in case of failure, and -2 in case of +# skipping the test-case. + +proc _selftest_setup { } { + global gdb_prompt + global INTERNAL_GDBFLAGS + + # Set a breakpoint at main + set function main if { [gdb_breakpoint $function "no-message"] != 1 } { untested "Cannot set breakpoint at $function, skipping testcase." return -2 } + # Debugging on Windows shows random threads starting and exiting, + # interfering with the tests. Disable them, since they are not useful here. + gdb_test_no_output "set print thread-events off" + # run yourself set description "run until breakpoint at $function" + set re_hs {[^\r\n]+} + set re_args [string cat \ + [string_to_regexp "("] \ + $re_hs \ + [string_to_regexp ")"]] + set re_pass \ + [multi_line \ + "Starting program: $re_hs" \ + ".*" \ + [string cat "Breakpoint $::decimal, $function $re_args at" \ + " ${re_hs}gdb.c:$re_hs"] \ + ".*"] + set re_xfail \ + [multi_line \ + "Starting program: $re_hs" \ + ".*" \ + "Breakpoint $::decimal, $function $re_args$re_hs" \ + ".*"] gdb_test_multiple "run $INTERNAL_GDBFLAGS" "$description" { - -re "Starting program.*Breakpoint \[0-9\]+,.*$function \\(.*\\).* at .*main.c:.*$gdb_prompt $" { - pass "$description" - } - -re "Starting program.*Breakpoint \[0-9\]+,.*$function \\(.*\\).*$gdb_prompt $" { - xfail "$description (line numbers scrambled?)" - } - -re "vfork: No more processes.*$gdb_prompt $" { - fail "$description (out of virtual memory)" - return -1 - } - -re ".*$gdb_prompt $" { - fail "$description" - return -1 - } + -re -wrap $re_pass { + pass $description + } + -re -wrap $re_xfail { + xfail "$description (line numbers scrambled?)" + } + -re -wrap "vfork: No more processes.*" { + fail "$description (out of virtual memory)" + return -1 + } + -re -wrap "" { + fail $description + return -1 + } } return 0 } -# Prepare for running a self-test by moving the GDB executable to a -# location where we can use it as the inferior. Return the filename -# of the new location. +# Return the location of the gdb executable to test. # # If the current testing setup is not suitable for running a # self-test, then return an empty string. @@ -108,58 +206,60 @@ proc selftest_prepare {} { # ... or seemingly testing with a cross debugger? Likely GDB # wouldn't be able to debug itself then... - if ![isnative] { + if {![isnative]} { return } # ... or with a stub-like server? I.e., gdbserver + "target # remote"? In that case we won't be able to pass command line - # arguments to GDB, and selftest_setup wants to do exactly that. - if [use_gdb_stub] { + # arguments to GDB, and _selftest_setup wants to do exactly that. + if {[use_gdb_stub]} { return } - # Run the test with self. Copy the file executable file in case - # this OS doesn't like to edit its own text space. - - set gdb_fullpath [find_gdb $::GDB] - - if {[is_remote host]} { - set xgdb x$::tool - } else { - set xgdb [standard_output_file x$::tool] - } - - # Remove any old copy lying around. - remote_file host delete $xgdb - - set filename [remote_download host $gdb_fullpath $xgdb] - - return $filename + return [_selftest_find_gdb $::GDB] } # A simple way to run some self-tests. -proc do_self_tests {function body} { +proc do_self_tests {body} { set file [selftest_prepare] if { $file eq "" } { return } - gdb_start + # Check if the gdb executable has debug info. + if { ![_selftest_check_executable_debug_info $file] } { + return + } + + # FILE might be a libtool wrapper. In order to debug the real thing, pass + # FILE on the command-line of the top-level gdb, and run under + # `libtool --mode=execute. libtool will replace FILE with the path to the + # real executable and set any path required for it to find its dependent + # libraries. + # + # If testing against an installed GDB, there won't be a libtool wrapper. + save_vars { ::GDB ::GDBFLAGS } { + if { ![_selftest_gdb_is_installed] && [_selftest_has_libtool] } { + set ::GDB "libtool --mode=execute $::GDB" + } + + set ::GDBFLAGS "$::GDBFLAGS $file" + gdb_start + } # When debugging GDB with GDB, some operations can take a relatively long # time, especially if the build is non-optimized. Bump the timeout for the # duration of the test. with_timeout_factor 10 { - set result [selftest_setup $file $function] + set result [_selftest_setup] if {$result == 0} { set result [uplevel $body] } } gdb_exit - catch "remote_file host delete $file" if {$result == -1} { warning "Couldn't test self" diff --git a/gdb/testsuite/lib/trace-support.exp b/gdb/testsuite/lib/trace-support.exp index a8d0699..46dff2f 100644 --- a/gdb/testsuite/lib/trace-support.exp +++ b/gdb/testsuite/lib/trace-support.exp @@ -24,19 +24,19 @@ # Used in many tests, kept here to avoid duplication. # -if [is_amd64_regs_target] { +if {[is_amd64_regs_target]} { set fpreg "rbp" set spreg "rsp" set pcreg "rip" -} elseif [is_x86_like_target] { +} elseif {[is_x86_like_target]} { set fpreg "ebp" set spreg "esp" set pcreg "eip" -} elseif [is_aarch64_target] { +} elseif {[is_aarch64_target]} { set fpreg "x29" set spreg "sp" set pcreg "pc" -} elseif [istarget "powerpc*-*-*"] { +} elseif {[istarget "powerpc*-*-*"]} { set fpreg "r31" set spreg "r1" set pcreg "pc" @@ -109,7 +109,7 @@ proc gdb_target_supports_trace { } { # Procedure: gdb_delete_tracepoints # Many of the tests depend on setting tracepoints at various places and # running until that tracepoint is reached. At times, we want to start -# with a clean slate with respect to tracepoints, so this utility proc +# with a clean slate with respect to tracepoints, so this utility proc # lets us do this without duplicating this code everywhere. # @@ -123,9 +123,9 @@ proc gdb_delete_tracepoints {} { exp_continue } -re ".*$gdb_prompt $" { # This happens if there were no tracepoints } - timeout { - perror "Delete all tracepoints in delete_tracepoints (timeout)" - return + timeout { + perror "Delete all tracepoints in delete_tracepoints (timeout)" + return } } send_gdb "info tracepoints\n" @@ -174,7 +174,7 @@ proc gdb_trace_setactions_command { actions_command testname tracepoint args } { -re "\(.*\)\[\r\n\]+\[ \t]*>$" { if { $expected_result != "" } { regsub "^\[^\r\n\]+\[\r\n\]+" "$expect_out(1,string)" "" out - if ![regexp $expected_result $out] { + if {![regexp $expected_result $out]} { set passfail "fail" } set expected_result "" @@ -192,7 +192,7 @@ proc gdb_trace_setactions_command { actions_command testname tracepoint args } { } -re "\(.*\)$gdb_prompt $" { if { $expected_result != "" } { - if ![regexp $expected_result $expect_out(1,string)] { + if {![regexp $expected_result $expect_out(1,string)]} { set passfail "fail" } set expected_result "" @@ -219,20 +219,20 @@ proc gdb_trace_setactions_command { actions_command testname tracepoint args } { # gdb_trace_setactions_command. # proc gdb_trace_setactions { testname tracepoint args } { - eval gdb_trace_setactions_command "actions" {$testname} {$tracepoint} $args + gdb_trace_setactions_command "actions" $testname $tracepoint {*}$args } # Define actions for a tracepoint, using the "commands" command. See # gdb_trace_setactions_command. # proc gdb_trace_setcommands { testname tracepoint args } { - eval gdb_trace_setactions_command "commands" {$testname} {$tracepoint} $args + gdb_trace_setactions_command "commands" $testname $tracepoint {*}$args } # # Procedure: gdb_tfind_test # Find a specified trace frame. -# Arguments: +# Arguments: # testname -- identifying string for pass/fail output # tfind_arg -- frame (line, PC, etc.) identifier # exp_res -- Expected result of frame test @@ -371,9 +371,9 @@ proc gdb_find_recursion_test_baseline { filename } { proc allow_in_proc_agent {} { global objdir - if [target_info exists in_proc_agent] { + if {[target_info exists in_proc_agent]} { return 1 - } elseif [file exists "$objdir/../../gdbserver/libinproctrace.so"] { + } elseif {[file exists "$objdir/../../gdbserver/libinproctrace.so"]} { return 1 } else { return 0 @@ -385,7 +385,7 @@ proc allow_in_proc_agent {} { proc get_in_proc_agent {} { global objdir - if [target_info exists in_proc_agent] { + if {[target_info exists in_proc_agent]} { return [target_info in_proc_agent] } else { return $objdir/../../gdbserver/libinproctrace.so @@ -403,7 +403,7 @@ proc generate_tracefile { binfile } { # Alternatively, load the binary and run it. If target doesn't # have fileio capabilities, tracefile can't be generated. Skip # the test. - if [target_info exists gdb,nofileio] { + if {[target_info exists gdb,nofileio]} { return 0 } diff --git a/gdb/testsuite/lib/tuiterm.exp b/gdb/testsuite/lib/tuiterm.exp index a0cd199..68fd677 100644 --- a/gdb/testsuite/lib/tuiterm.exp +++ b/gdb/testsuite/lib/tuiterm.exp @@ -33,1264 +33,1690 @@ namespace eval Term { variable _resize_count - proc _log { what } { - verbose "+++ $what" - } + variable _TERM + set _TERM "" - # Call BODY, then log WHAT along with the original and new cursor position. - proc _log_cur { what body } { - variable _cur_row - variable _cur_col + variable _alternate + variable _alternate_setup + set _alternate 0 + set _alternate_setup 0 +} + +proc Term::_log { what } { + verbose "+++ $what" +} - set orig_cur_row $_cur_row - set orig_cur_col $_cur_col +# Call BODY, then log WHAT along with the original and new cursor position. +proc Term::_log_cur { what body } { + variable _cur_row + variable _cur_col - uplevel $body + set orig_cur_row $_cur_row + set orig_cur_col $_cur_col + + set code [catch {uplevel $body} result] - _log "$what, cursor: ($orig_cur_row, $orig_cur_col) -> ($_cur_row, $_cur_col)" + _log "$what, cursor: ($orig_cur_row, $orig_cur_col) -> ($_cur_row, $_cur_col)" + + if { $code == 1 } { + global errorInfo errorCode + return -code $code -errorinfo $errorInfo -errorcode $errorCode $result + } else { + return -code $code $result } +} - # If ARG is empty, return DEF: otherwise ARG. This is useful for - # defaulting arguments in CSIs. - proc _default {arg def} { - if {$arg == ""} { - return $def - } - return $arg +# If ARG is empty, return DEF: otherwise ARG. This is useful for +# defaulting arguments in CSIs. +proc Term::_default {arg def} { + if {$arg == ""} { + return $def } + return $arg +} - # Erase in the line Y from SX to just before EX. - proc _clear_in_line {sx ex y} { - variable _attrs - variable _chars - set lattr [array get _attrs] - while {$sx < $ex} { - set _chars($sx,$y) [list " " $lattr] - incr sx - } +# Erase in the line Y from SX to just before EX. +proc Term::_clear_in_line {sx ex y} { + variable _attrs + variable _chars + set lattr [array get _attrs] + while {$sx < $ex} { + set _chars($sx,$y) [list " " $lattr] + incr sx } +} - # Erase the lines from SY to just before EY. - proc _clear_lines {sy ey} { - variable _cols - while {$sy < $ey} { - _clear_in_line 0 $_cols $sy - incr sy - } +# Erase the lines from SY to just before EY. +proc Term::_clear_lines {sy ey} { + variable _cols + while {$sy < $ey} { + _clear_in_line 0 $_cols $sy + incr sy } +} + +# Beep. +proc Term::_ctl_0x07 {} { +} + +# Return 1 if tuiterm has the bw/auto_left_margin enabled. +proc Term::_have_bw {} { + return [expr \ + { [string equal $Term::_TERM "ansiw"] \ + || [string equal $Term::_TERM "ansis"] }] +} - # Beep. - proc _ctl_0x07 {} { +# Backspace. +proc Term::_ctl_0x08 { {bw -1} } { + if { $bw == -1 } { + set bw [_have_bw] } + _log_cur "Backspace, bw == $bw" { + variable _cur_col + variable _cur_row + variable _cols - # Backspace. - proc _ctl_0x08 {} { - _log_cur "Backspace" { - variable _cur_col + if { $_cur_col > 0 } { + # No wrapping needed. + incr _cur_col -1 + return + } - if {$_cur_col > 0} { - incr _cur_col -1 - } + if { ! $bw } { + # Wrapping not enabled. + return } + + if { $_cur_row == 0 } { + # Can't wrap. + return + } + + # Wrap to previous line. + set _cur_col [expr $_cols - 1] + incr _cur_row -1 } +} - # Linefeed. - proc _ctl_0x0a {} { - _log_cur "Line feed" { - variable _cur_row - variable _rows - variable _cols - variable _chars - - incr _cur_row 1 - while {$_cur_row >= $_rows} { - # Scroll the display contents. We scroll one line at - # a time here; as _cur_row was only increased by one, - # a single line scroll should be enough to put the - # cursor back on the screen. But we wrap the - # scrolling inside a while loop just to be on the safe - # side. - for {set y 0} {$y < [expr $_rows - 1]} {incr y} { - set next_y [expr $y + 1] - for {set x 0} {$x < $_cols} {incr x} { - set _chars($x,$y) $_chars($x,$next_y) - } - } +# Linefeed. +proc Term::_ctl_0x0a {} { + _log_cur "Line feed" { + variable _cur_row + variable _rows + variable _cols + variable _chars - incr _cur_row -1 + incr _cur_row 1 + while {$_cur_row >= $_rows} { + # Scroll the display contents. We scroll one line at + # a time here; as _cur_row was only increased by one, + # a single line scroll should be enough to put the + # cursor back on the screen. But we wrap the + # scrolling inside a while loop just to be on the safe + # side. + for {set y 0} {$y < [expr $_rows - 1]} {incr y} { + set next_y [expr $y + 1] + for {set x 0} {$x < $_cols} {incr x} { + set _chars($x,$y) $_chars($x,$next_y) + } } + + incr _cur_row -1 } } +} - # Carriage return. - proc _ctl_0x0d {} { - _log_cur "Carriage return" { - variable _cur_col +# Carriage return. +proc Term::_ctl_0x0d {} { + _log_cur "Carriage return" { + variable _cur_col - set _cur_col 0 - } + set _cur_col 0 } +} - # Insert Character. - # - # https://vt100.net/docs/vt510-rm/ICH.html - proc _csi_@ {args} { - set n [_default [lindex $args 0] 1] +# Designate G0 Character Set, USASCII (ESC ( B) +# +# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html (see "ESC ( C", case C = B) +proc Term::_esc_0x28_B {} { + _log "ignored: G0: USASCII" +} - _log_cur "Insert Character ($n)" { - variable _cur_col - variable _cur_row - variable _cols - variable _chars +# Designate G0 Character Set, DEC Special Character and Line Drawing Set (ESC ( 0) +# +# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html (see "ESC ( C", case C = 0) +proc Term::_esc_0x28_0 {} { + _log "ignored: G0: DEC Special Character and Line Drawing Set" +} - # Move characters right of the cursor right by N positions, - # starting with the rightmost one. - for {set in_col [expr $_cols - $n - 1]} {$in_col >= $_cur_col} {incr in_col -1} { - set out_col [expr $in_col + $n] - set _chars($out_col,$_cur_row) $_chars($in_col,$_cur_row) - } +# DECKPAM (Application Keypad, ESC =) +# +# https://vt100.net/docs/vt510-rm/DECKPAM.html +proc Term::_esc_0x3d {} { + _log "ignored: Application Keypad" +} + +# DECKPNM (Normal Keypad, ESC >) +# +# https://vt100.net/docs/vt510-rm/DECKPNM.html +proc Term::_esc_0x3e {} { + _log "ignored: Normal Keypad" +} - # Write N blank spaces starting from the cursor. - _clear_in_line $_cur_col [expr $_cur_col + $n] $_cur_row +# Insert Character. +# +# https://vt100.net/docs/vt510-rm/ICH.html +proc Term::_csi_@ {args} { + set n [_default [lindex $args 0] 1] + + _log_cur "Insert Character ($n)" { + variable _cur_col + variable _cur_row + variable _cols + variable _chars + + # Move characters right of the cursor right by N positions, + # starting with the rightmost one. + for {set in_col [expr $_cols - $n - 1]} {$in_col >= $_cur_col} {incr in_col -1} { + set out_col [expr $in_col + $n] + set _chars($out_col,$_cur_row) $_chars($in_col,$_cur_row) } + + # Write N blank spaces starting from the cursor. + _clear_in_line $_cur_col [expr $_cur_col + $n] $_cur_row } +} - # Cursor Up. - # - # https://vt100.net/docs/vt510-rm/CUU.html - proc _csi_A {args} { - set arg [_default [lindex $args 0] 1] +# Horizontal Position Absolute. +# +# https://vt100.net/docs/vt510-rm/HPA.html +proc Term::_csi_` {args} { + # Same as Cursor Horizontal Absolute. + return [Term::_csi_G {*}$args] +} - _log_cur "Cursor Up ($arg)" { - variable _cur_row +# Cursor Up. +# +# https://vt100.net/docs/vt510-rm/CUU.html +proc Term::_csi_A {args} { + set arg [_default [lindex $args 0] 1] - set _cur_row [expr {max ($_cur_row - $arg, 0)}] - } + _log_cur "Cursor Up ($arg)" { + variable _cur_row + + set _cur_row [expr {max ($_cur_row - $arg, 0)}] } +} - # Cursor Down. - # - # https://vt100.net/docs/vt510-rm/CUD.html - proc _csi_B {args} { - set arg [_default [lindex $args 0] 1] +# Cursor Down. +# +# https://vt100.net/docs/vt510-rm/CUD.html +proc Term::_csi_B {args} { + set arg [_default [lindex $args 0] 1] - _log_cur "Cursor Down ($arg)" { - variable _cur_row - variable _rows + _log_cur "Cursor Down ($arg)" { + variable _cur_row + variable _rows - set _cur_row [expr {min ($_cur_row + $arg, $_rows - 1)}] - } + set _cur_row [expr {min ($_cur_row + $arg, $_rows - 1)}] } +} - # Cursor Forward. - # - # https://vt100.net/docs/vt510-rm/CUF.html - proc _csi_C {args} { - set arg [_default [lindex $args 0] 1] +# Cursor Forward. +# +# https://vt100.net/docs/vt510-rm/CUF.html +proc Term::_csi_C {args} { + set arg [_default [lindex $args 0] 1] - _log_cur "Cursor Forward ($arg)" { - variable _cur_col - variable _cols + _log_cur "Cursor Forward ($arg)" { + variable _cur_col + variable _cols - set _cur_col [expr {min ($_cur_col + $arg, $_cols - 1)}] - } + set _cur_col [expr {min ($_cur_col + $arg, $_cols - 1)}] } +} - # Cursor Backward. - # - # https://vt100.net/docs/vt510-rm/CUB.html - proc _csi_D {args} { - set arg [_default [lindex $args 0] 1] +# Cursor Backward. +# +# https://vt100.net/docs/vt510-rm/CUB.html +proc Term::_csi_D {args} { + set arg [_default [lindex $args 0] 1] - _log_cur "Cursor Backward ($arg)" { - variable _cur_col + _log_cur "Cursor Backward ($arg)" { + variable _cur_col - set _cur_col [expr {max ($_cur_col - $arg, 0)}] - } + set _cur_col [expr {max ($_cur_col - $arg, 0)}] } +} - # Cursor Next Line. - # - # https://vt100.net/docs/vt510-rm/CNL.html - proc _csi_E {args} { - set arg [_default [lindex $args 0] 1] +# Cursor Next Line. +# +# https://vt100.net/docs/vt510-rm/CNL.html +proc Term::_csi_E {args} { + set arg [_default [lindex $args 0] 1] - _log_cur "Cursor Next Line ($arg)" { - variable _cur_col - variable _cur_row - variable _rows + _log_cur "Cursor Next Line ($arg)" { + variable _cur_col + variable _cur_row + variable _rows - set _cur_col 0 - set _cur_row [expr {min ($_cur_row + $arg, $_rows - 1)}] - } + set _cur_col 0 + set _cur_row [expr {min ($_cur_row + $arg, $_rows - 1)}] } +} - # Cursor Previous Line. - # - # https://vt100.net/docs/vt510-rm/CPL.html - proc _csi_F {args} { - set arg [_default [lindex $args 0] 1] +# Cursor Previous Line. +# +# https://vt100.net/docs/vt510-rm/CPL.html +proc Term::_csi_F {args} { + set arg [_default [lindex $args 0] 1] - _log_cur "Cursor Previous Line ($arg)" { - variable _cur_col - variable _cur_row - variable _rows + _log_cur "Cursor Previous Line ($arg)" { + variable _cur_col + variable _cur_row + variable _rows - set _cur_col 0 - set _cur_row [expr {max ($_cur_row - $arg, 0)}] - } + set _cur_col 0 + set _cur_row [expr {max ($_cur_row - $arg, 0)}] } +} - # Cursor Horizontal Absolute. - # - # https://vt100.net/docs/vt510-rm/CHA.html - proc _csi_G {args} { - set arg [_default [lindex $args 0] 1] +# Cursor Horizontal Absolute. +# +# https://vt100.net/docs/vt510-rm/CHA.html +proc Term::_csi_G {args} { + set arg [_default [lindex $args 0] 1] - _log_cur "Cursor Horizontal Absolute ($arg)" { - variable _cur_col - variable _cols + _log_cur "Cursor Horizontal Absolute ($arg)" { + variable _cur_col + variable _cols - set _cur_col [expr {min ($arg - 1, $_cols)}] - } + set _cur_col [expr {min ($arg, $_cols)} - 1] } +} - # Cursor Position. - # - # https://vt100.net/docs/vt510-rm/CUP.html - proc _csi_H {args} { - set row [_default [lindex $args 0] 1] - set col [_default [lindex $args 1] 1] +# Cursor Position. +# +# https://vt100.net/docs/vt510-rm/CUP.html +proc Term::_csi_H {args} { + set row [_default [lindex $args 0] 1] + set col [_default [lindex $args 1] 1] - _log_cur "Cursor Position ($row, $col)" { - variable _cur_col - variable _cur_row + _log_cur "Cursor Position ($row, $col)" { + variable _cur_col + variable _cur_row - set _cur_row [expr {$row - 1}] - set _cur_col [expr {$col - 1}] - } + set _cur_row [expr {$row - 1}] + set _cur_col [expr {$col - 1}] } +} - # Cursor Horizontal Forward Tabulation. - # - # https://vt100.net/docs/vt510-rm/CHT.html - proc _csi_I {args} { - set n [_default [lindex $args 0] 1] +# Cursor Horizontal Forward Tabulation. +# +# https://vt100.net/docs/vt510-rm/CHT.html +proc Term::_csi_I {args} { + set n [_default [lindex $args 0] 1] - _log_cur "Cursor Horizontal Forward Tabulation ($n)" { - variable _cur_col - variable _cols + _log_cur "Cursor Horizontal Forward Tabulation ($n)" { + variable _cur_col + variable _cols - incr _cur_col [expr {$n * 8 - $_cur_col % 8}] - if {$_cur_col >= $_cols} { - set _cur_col [expr {$_cols - 1}] - } + incr _cur_col [expr {$n * 8 - $_cur_col % 8}] + if {$_cur_col >= $_cols} { + set _cur_col [expr {$_cols - 1}] } } +} - # Erase in Display. - # - # https://vt100.net/docs/vt510-rm/ED.html - proc _csi_J {args} { - set arg [_default [lindex $args 0] 0] - - _log_cur "Erase in Display ($arg)" { - variable _cur_col - variable _cur_row - variable _rows - variable _cols - - if {$arg == 0} { - # Cursor (inclusive) to end of display. - _clear_in_line $_cur_col $_cols $_cur_row - _clear_lines [expr {$_cur_row + 1}] $_rows - } elseif {$arg == 1} { - # Beginning of display to cursor (inclusive). - _clear_lines 0 $_cur_row - _clear_in_line 0 [expr $_cur_col + 1] $_cur_row - } elseif {$arg == 2} { - # Entire display. - _clear_lines 0 $_rows - } +# Erase in Display. +# +# https://vt100.net/docs/vt510-rm/ED.html +proc Term::_csi_J {args} { + set arg [_default [lindex $args 0] 0] + + _log_cur "Erase in Display ($arg)" { + variable _cur_col + variable _cur_row + variable _rows + variable _cols + + if {$arg == 0} { + # Cursor (inclusive) to end of display. + _clear_in_line $_cur_col $_cols $_cur_row + _clear_lines [expr {$_cur_row + 1}] $_rows + } elseif {$arg == 1} { + # Beginning of display to cursor (inclusive). + _clear_lines 0 $_cur_row + _clear_in_line 0 [expr $_cur_col + 1] $_cur_row + } elseif {$arg == 2} { + # Entire display. + _clear_lines 0 $_rows } } +} - # Erase in Line. - # - # https://vt100.net/docs/vt510-rm/EL.html - proc _csi_K {args} { - set arg [_default [lindex $args 0] 0] +# Erase in Line. +# +# https://vt100.net/docs/vt510-rm/EL.html +proc Term::_csi_K {args} { + set arg [_default [lindex $args 0] 0] - _log_cur "Erase in Line ($arg)" { - variable _cur_col - variable _cur_row - variable _cols + _log_cur "Erase in Line ($arg)" { + variable _cur_col + variable _cur_row + variable _cols - if {$arg == 0} { - # Cursor (inclusive) to end of line. - _clear_in_line $_cur_col $_cols $_cur_row - } elseif {$arg == 1} { - # Beginning of line to cursor (inclusive). - _clear_in_line 0 [expr $_cur_col + 1] $_cur_row - } elseif {$arg == 2} { - # Entire line. - _clear_in_line 0 $_cols $_cur_row - } + if {$arg == 0} { + # Cursor (inclusive) to end of line. + _clear_in_line $_cur_col $_cols $_cur_row + } elseif {$arg == 1} { + # Beginning of line to cursor (inclusive). + _clear_in_line 0 [expr $_cur_col + 1] $_cur_row + } elseif {$arg == 2} { + # Entire line. + _clear_in_line 0 $_cols $_cur_row } } +} - # Insert Line - # - # https://vt100.net/docs/vt510-rm/IL.html - proc _csi_L {args} { - set arg [_default [lindex $args 0] 1] +# Insert Line +# +# https://vt100.net/docs/vt510-rm/IL.html +proc Term::_csi_L {args} { + set arg [_default [lindex $args 0] 1] - _log_cur "Insert Line ($arg)" { - variable _cur_col - variable _cur_row - variable _rows - variable _cols - variable _chars + _log_cur "Insert Line ($arg)" { + variable _cur_col + variable _cur_row + variable _rows + variable _cols + variable _chars - set y [expr $_rows - 2] - set next_y [expr $y + $arg] - while {$y >= $_cur_row} { - for {set x 0} {$x < $_cols} {incr x} { - set _chars($x,$next_y) $_chars($x,$y) - } - incr y -1 - incr next_y -1 + set y [expr $_rows - 2] + set next_y [expr $y + $arg] + while {$y >= $_cur_row} { + for {set x 0} {$x < $_cols} {incr x} { + set _chars($x,$next_y) $_chars($x,$y) } - - _clear_lines $_cur_row [expr $_cur_row + $arg] + incr y -1 + incr next_y -1 } + + _clear_lines $_cur_row [expr $_cur_row + $arg] } +} - # Delete line. - # - # https://vt100.net/docs/vt510-rm/DL.html - proc _csi_M {args} { - set count [_default [lindex $args 0] 1] +# Delete line. +# +# https://vt100.net/docs/vt510-rm/DL.html +proc Term::_csi_M {args} { + set count [_default [lindex $args 0] 1] - _log_cur "Delete line ($count)" { - variable _cur_row - variable _rows - variable _cols - variable _chars + _log_cur "Delete line ($count)" { + variable _cur_row + variable _rows + variable _cols + variable _chars - set y $_cur_row - set next_y [expr {$y + $count}] - while {$next_y < $_rows} { - for {set x 0} {$x < $_cols} {incr x} { - set _chars($x,$y) $_chars($x,$next_y) - } - incr y - incr next_y + set y $_cur_row + set next_y [expr {$y + $count}] + while {$next_y < $_rows} { + for {set x 0} {$x < $_cols} {incr x} { + set _chars($x,$y) $_chars($x,$next_y) } - _clear_lines $y $_rows + incr y + incr next_y } + _clear_lines $y $_rows } +} - # Delete Character. - # - # https://vt100.net/docs/vt510-rm/DCH.html - proc _csi_P {args} { - set count [_default [lindex $args 0] 1] - - _log_cur "Delete character ($count)" { - variable _cur_row - variable _cur_col - variable _chars - variable _cols +# Delete Character. +# +# https://vt100.net/docs/vt510-rm/DCH.html +proc Term::_csi_P {args} { + set count [_default [lindex $args 0] 1] - # Move all characters right of the cursor N positions left. - set out_col [expr $_cur_col] - set in_col [expr $_cur_col + $count] + _log_cur "Delete character ($count)" { + variable _cur_row + variable _cur_col + variable _chars + variable _cols - while {$in_col < $_cols} { - set _chars($out_col,$_cur_row) $_chars($in_col,$_cur_row) - incr in_col - incr out_col - } + # Move all characters right of the cursor N positions left. + set out_col [expr $_cur_col] + set in_col [expr $_cur_col + $count] - # Clear the rest of the line. - _clear_in_line $out_col $_cols $_cur_row + while {$in_col < $_cols} { + set _chars($out_col,$_cur_row) $_chars($in_col,$_cur_row) + incr in_col + incr out_col } + + # Clear the rest of the line. + _clear_in_line $out_col $_cols $_cur_row } +} - # Pan Down - # - # https://vt100.net/docs/vt510-rm/SU.html - proc _csi_S {args} { - set count [_default [lindex $args 0] 1] +# Pan Down +# +# https://vt100.net/docs/vt510-rm/SU.html +proc Term::_csi_S {args} { + set count [_default [lindex $args 0] 1] - _log_cur "Pan Down ($count)" { - variable _cur_col - variable _cur_row - variable _cols - variable _rows - variable _chars + _log_cur "Pan Down ($count)" { + variable _cur_col + variable _cur_row + variable _cols + variable _rows + variable _chars - # The following code is written without consideration for - # the scroll margins. At this time this comment was - # written the tuiterm library doesn't support the scroll - # margins. If/when that changes, then the following will - # need to be updated. + # The following code is written without consideration for + # the scroll margins. At this time this comment was + # written the tuiterm library doesn't support the scroll + # margins. If/when that changes, then the following will + # need to be updated. - set dy 0 - set y $count + set dy 0 + set y $count - while {$y < $_rows} { - for {set x 0} {$x < $_cols} {incr x} { - set _chars($x,$dy) $_chars($x,$y) - } - incr y 1 - incr dy 1 + while {$y < $_rows} { + for {set x 0} {$x < $_cols} {incr x} { + set _chars($x,$dy) $_chars($x,$y) } - - _clear_lines $dy $_rows + incr y 1 + incr dy 1 } + + _clear_lines $dy $_rows } +} - # Pan Up - # - # https://vt100.net/docs/vt510-rm/SD.html - proc _csi_T {args} { - set count [_default [lindex $args 0] 1] +# Pan Up +# +# https://vt100.net/docs/vt510-rm/SD.html +proc Term::_csi_T {args} { + set count [_default [lindex $args 0] 1] - _log_cur "Pan Up ($count)" { - variable _cur_col - variable _cur_row - variable _cols - variable _rows - variable _chars + _log_cur "Pan Up ($count)" { + variable _cur_col + variable _cur_row + variable _cols + variable _rows + variable _chars - # The following code is written without consideration for - # the scroll margins. At this time this comment was - # written the tuiterm library doesn't support the scroll - # margins. If/when that changes, then the following will - # need to be updated. + # The following code is written without consideration for + # the scroll margins. At this time this comment was + # written the tuiterm library doesn't support the scroll + # margins. If/when that changes, then the following will + # need to be updated. - set y [expr $_rows - $count] - set dy $_rows + set y [expr $_rows - $count] + set dy $_rows - while {$dy >= $count} { - for {set x 0} {$x < $_cols} {incr x} { - set _chars($x,$dy) $_chars($x,$y) - } - incr y -1 - incr dy -1 + while {$dy >= $count} { + for {set x 0} {$x < $_cols} {incr x} { + set _chars($x,$dy) $_chars($x,$y) } - - _clear_lines 0 $count + incr y -1 + incr dy -1 } + + _clear_lines 0 $count } +} - # Erase chars. - # - # https://vt100.net/docs/vt510-rm/ECH.html - proc _csi_X {args} { - set n [_default [lindex $args 0] 1] +# Erase chars. +# +# https://vt100.net/docs/vt510-rm/ECH.html +proc Term::_csi_X {args} { + set n [_default [lindex $args 0] 1] - _log_cur "Erase chars ($n)" { - # Erase characters but don't move cursor. - variable _cur_col - variable _cur_row - variable _attrs - variable _chars + _log_cur "Erase chars ($n)" { + # Erase characters but don't move cursor. + variable _cur_col + variable _cur_row + variable _attrs + variable _chars - set lattr [array get _attrs] - set x $_cur_col - for {set i 0} {$i < $n} {incr i} { - set _chars($x,$_cur_row) [list " " $lattr] - incr x - } + set lattr [array get _attrs] + set x $_cur_col + for {set i 0} {$i < $n} {incr i} { + set _chars($x,$_cur_row) [list " " $lattr] + incr x } } +} - # Cursor Backward Tabulation. - # - # https://vt100.net/docs/vt510-rm/CBT.html - proc _csi_Z {args} { - set n [_default [lindex $args 0] 1] +# Cursor Backward Tabulation. +# +# https://vt100.net/docs/vt510-rm/CBT.html +proc Term::_csi_Z {args} { + set n [_default [lindex $args 0] 1] - _log_cur "Cursor Backward Tabulation ($n)" { - variable _cur_col + _log_cur "Cursor Backward Tabulation ($n)" { + variable _cur_col - set _cur_col [expr {max (int (($_cur_col - 1) / 8) * 8 - ($n - 1) * 8, 0)}] - } + set _cur_col [expr {max (int (($_cur_col - 1) / 8) * 8 - ($n - 1) * 8, 0)}] } +} - # Repeat. - # - # https://www.xfree86.org/current/ctlseqs.html (See `(REP)`) - proc _csi_b {args} { - set n [_default [lindex $args 0] 1] +# Repeat. +# +# https://www.xfree86.org/current/ctlseqs.html (See `(REP)`) +proc Term::_csi_b {args} { + set n [_default [lindex $args 0] 1] - _log_cur "Repeat ($n)" { - variable _last_char + _log_cur "Repeat ($n)" { + variable _last_char - _insert [string repeat $_last_char $n] - } + _insert [string repeat $_last_char $n] } +} - # Vertical Line Position Absolute. - # - # https://vt100.net/docs/vt510-rm/VPA.html - proc _csi_d {args} { - set row [_default [lindex $args 0] 1] +# Vertical Line Position Absolute. +# +# https://vt100.net/docs/vt510-rm/VPA.html +proc Term::_csi_d {args} { + set row [_default [lindex $args 0] 1] - _log_cur "Vertical Line Position Absolute ($row)" { - variable _cur_row - variable _rows + _log_cur "Vertical Line Position Absolute ($row)" { + variable _cur_row + variable _rows - set _cur_row [expr min ($row - 1, $_rows - 1)] - } + set _cur_row [expr min ($row - 1, $_rows - 1)] } +} - # Reset the attributes in attributes array UPVAR_NAME to the default values. - proc _reset_attrs { upvar_name } { - upvar $upvar_name var - array set var { - intensity normal - fg default - bg default - underline 0 - reverse 0 - invisible 0 - blinking 0 +# Set Mode (SM, CSI h) +# +# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html +proc Term::_csi_h { args } { + foreach item $args { + switch -exact -- $item { + 4 { + # Insert Mode (IRM) + _log "ignored: insert mode" + } + default { + error unsupported + } } } +} - # Translate the color numbers as used in proc _csi_m to a name. - proc _color_attr { n } { - switch -exact -- $n { - 0 { - return black +# Reset Mode (RM, CSI l) +# +# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html +proc Term::_csi_l { args } { + foreach item $args { + switch -exact -- $item { + 4 { + # Replace Mode (IRM) + _log "ignored: replace mode" + } + default { + error unsupported } + } + } +} + +# Set Scrolling Region (DECSTBM, CSI Ps ; Ps r) +# +# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html +proc Term::_csi_r { top bottom } { + _log "ignored: set scrolling region" +} + +# Window manipulation (XTWINOPS, CSI Ps ; Ps ; Ps t) +# +# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html +proc Term::_csi_t { arg1 arg2 arg3 } { + if { $arg1 == 22 && $arg2 == 0 && $arg3 == 0 } { + _log "ignored: Save xterm icon and window title on stack" + return + } + + if { $arg1 == 23 && $arg2 == 0 && $arg3 == 0 } { + _log "ignored: Restore xterm icon and window title from stack" + return + } + + error unsupported +} + +# DECSET (CSI ? h) +# +# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking +proc Term::_csi_0x3f_h { args } { + foreach item $args { + switch -exact -- $item { 1 { - return red + _log "ignored: Application Cursor Keys" } - 2 { - return green + 7 { + _log "ignored: autowrap mode" } - 3 { - return yellow + 1000 { + _log "ignored: Send Mouse X & Y on button press and release" } - 4 { - return blue + 1006 { + _log "ignored: Enable SGR Mouse Mode" } - 5 { - return magenta + 1049 { + _log "switch to alternate screen" + _set_alternate 1 } - 6 { - return cyan + default { + error unsupported + } + } + } +} + +# DECRST (CSI ? l) +# +# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html#h2-Mouse-Tracking +proc Term::_csi_0x3f_l { args } { + foreach item $args { + switch -exact -- $item { + 1 { + _log "ignored: Normal Cursor Keys" } 7 { - return white + _log "ignored: no autowrap mode" + } + 1000 { + _log "ignored: Don't send Mouse X & Y on button press and release" + } + 1006 { + _log "ignored: Disable SGR Mouse Mode" + } + 1049 { + _log "switch from alternate screen" + _set_alternate 0 + } + default { + error "unsupported" } - default { error "unsupported color number: $n" } } } +} - # Select Graphic Rendition. - # - # https://vt100.net/docs/vt510-rm/SGR.html - proc _csi_m {args} { - _log_cur "Select Graphic Rendition ([join $args {, }])" { - variable _attrs +# Reset the attributes in attributes array UPVAR_NAME to the default values. +proc Term::_reset_attrs { upvar_name } { + upvar $upvar_name var + array set var { + intensity normal + fg default + bg default + underline 0 + reverse 0 + invisible 0 + blinking 0 + } +} - foreach item $args { - switch -exact -- $item { - "" - 0 { - _reset_attrs _attrs - } - 1 { - set _attrs(intensity) bold - } - 2 { - set _attrs(intensity) dim - } - 4 { - set _attrs(underline) 1 - } - 5 { - set _attrs(blinking) 1 - } - 7 { - set _attrs(reverse) 1 - } - 8 { - set _attrs(invisible) 1 - } - 22 { - set _attrs(intensity) normal - } - 24 { - set _attrs(underline) 0 - } - 25 { - set _attrs(blinking) 0 - } - 27 { - set _attrs(reverse) 0 - } - 28 { - set _attrs(invisible) 0 - } - 30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 { - set _attrs(fg) [_color_attr [expr $item - 30]] - } - 39 { - set _attrs(fg) default - } - 40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 { - set _attrs(bg) [_color_attr [expr $item - 40]] - } - 49 { - set _attrs(bg) default - } +# Translate the color numbers as used in proc _csi_m to a name. +proc Term::_color_attr { n } { + switch -exact -- $n { + 0 { + return black + } + 1 { + return red + } + 2 { + return green + } + 3 { + return yellow + } + 4 { + return blue + } + 5 { + return magenta + } + 6 { + return cyan + } + 7 { + return white + } + default { error "unsupported color number: $n" } + } +} + +# Select Graphic Rendition. +# +# https://vt100.net/docs/vt510-rm/SGR.html +proc Term::_csi_m {args} { + if { [llength $args] == 0 } { + # Apply default. + set args [list 0] + } + + _log_cur "Select Graphic Rendition ([join $args {, }])" { + variable _attrs + + foreach item $args { + switch -exact -- $item { + "" - 0 { + _reset_attrs _attrs + } + 1 { + set _attrs(intensity) bold + } + 2 { + set _attrs(intensity) dim + } + 4 { + set _attrs(underline) 1 + } + 5 { + set _attrs(blinking) 1 + } + 7 { + set _attrs(reverse) 1 + } + 8 { + set _attrs(invisible) 1 + } + 22 { + set _attrs(intensity) normal + } + 24 { + set _attrs(underline) 0 + } + 25 { + set _attrs(blinking) 0 + } + 27 { + set _attrs(reverse) 0 + } + 28 { + set _attrs(invisible) 0 + } + 30 - 31 - 32 - 33 - 34 - 35 - 36 - 37 { + set _attrs(fg) [_color_attr [expr $item - 30]] + } + 39 { + set _attrs(fg) default + } + 40 - 41 - 42 - 43 - 44 - 45 - 46 - 47 { + set _attrs(bg) [_color_attr [expr $item - 40]] + } + 49 { + set _attrs(bg) default } } } } +} - # Insert string at the cursor location. - proc _insert {str} { - _log_cur "Inserted string '$str'" { - _log "Inserting string '$str'" - - variable _cur_col - variable _cur_row - variable _rows - variable _cols - variable _attrs - variable _chars - set lattr [array get _attrs] - foreach char [split $str {}] { - _log_cur " Inserted char '$char'" { - set _chars($_cur_col,$_cur_row) [list $char $lattr] - incr _cur_col - if {$_cur_col >= $_cols} { - set _cur_col 0 - incr _cur_row - if {$_cur_row >= $_rows} { - error "FIXME scroll" - } +# Request Terminal Parameters (DECREQTPARM) +# +# https://invisible-island.net/xterm/ctlseqs/ctlseqs.html +# https://vt100.net/docs/vt100-ug/chapter3.html +proc Term::_csi_x {} { + # Ignore. +} + +# Insert string at the cursor location. +proc Term::_insert {str} { + _log_cur "Inserted string '$str'" { + _log "Inserting string '$str'" + + variable _cur_col + variable _cur_row + variable _rows + variable _cols + variable _attrs + variable _chars + set lattr [array get _attrs] + foreach char [split $str {}] { + _log_cur " Inserted char '$char'" { + set _chars($_cur_col,$_cur_row) [list $char $lattr] + incr _cur_col + if {$_cur_col >= $_cols} { + set _cur_col 0 + incr _cur_row + if {$_cur_row >= $_rows} { + error "FIXME scroll" } } } } + + variable _last_char + set _last_char [string index $str end] } +} - # Move the cursor to the (0-based) COL and ROW positions. - proc _move_cursor { col row } { - variable _cols - variable _rows - variable _cur_col - variable _cur_row +# Move the cursor to the (0-based) COL and ROW positions. +proc Term::_move_cursor { col row } { + variable _cols + variable _rows + variable _cur_col + variable _cur_row - if { $col < 0 || $col >= $_cols } { - error "_move_cursor: invalid col value: $col" - } + if { $col < 0 || $col >= $_cols } { + error "_move_cursor: invalid col value: $col" + } + + if { $row < 0 || $row >= $_rows } { + error "_move_cursor: invalid row value: $row" + } - if { $row < 0 || $row >= $_rows } { - error "_move_cursor: invalid row value: $row" - } + set _cur_col $col + set _cur_row $row +} - set _cur_col $col - set _cur_row $row +# Enable or disable alternate screen. +proc Term::_set_alternate { enable } { + variable _alternate + if { $enable == $_alternate } { + return } + set _alternate $enable - # Initialize. - proc _setup {rows cols} { - global stty_init - set stty_init "rows $rows columns $cols" + variable _attrs + variable _chars + variable _cur_col + variable _cur_row - variable _rows - variable _cols - variable _cur_col - variable _cur_row - variable _attrs - variable _resize_count + variable _save_attrs + variable _save_chars + variable _save_cur_col + variable _save_cur_row - set _rows $rows - set _cols $cols - set _cur_col 0 - set _cur_row 0 - set _resize_count 0 - _reset_attrs _attrs - - _clear_lines 0 $_rows - } - - # Accept some output from gdb and update the screen. - # Return 1 if successful, or 0 if a timeout occurred. - proc accept_gdb_output { } { - global expect_out - gdb_expect { - -re "^\[\x07\x08\x0a\x0d\]" { - scan $expect_out(0,string) %c val - set hexval [format "%02x" $val] - _log "wait_for: _ctl_0x${hexval}" - _ctl_0x${hexval} - } - -re "^\x1b(\[0-9a-zA-Z\])" { - _log "wait_for: unsupported escape" - error "unsupported escape" - } - -re "^\x1b\\\[(\[0-9;\]*)(\[a-zA-Z@\])" { - set cmd $expect_out(2,string) - set params [split $expect_out(1,string) ";"] - _log "wait_for: _csi_$cmd <<<$expect_out(1,string)>>>" - eval _csi_$cmd $params - } - -re "^\[^\x07\x08\x0a\x0d\x1b\]+" { - _insert $expect_out(0,string) - variable _last_char - set _last_char [string index $expect_out(0,string) end] - } + variable _alternate_setup - timeout { - # Assume a timeout means we somehow missed the - # expected result, and carry on. - warning "timeout in accept_gdb_output" - dump_screen - return 0 - } - } + if { $_alternate_setup } { + set tmp $_save_chars + } + set _save_chars [array get _chars] + if { $_alternate_setup } { + array set _chars $tmp + } - return 1 + if { $_alternate_setup } { + set tmp $_save_attrs + } + set _save_attrs [array get _attrs] + if { $_alternate_setup } { + array set _attrs $tmp } - # Print arg using "verbose -log" if DEBUG_TUI_MATCHING == 1. - proc debug_tui_matching { arg } { - set debug 0 - if { [info exists ::DEBUG_TUI_MATCHING] } { - set debug $::DEBUG_TUI_MATCHING - } + if { $_alternate_setup } { + set tmp $_save_cur_col + } + set _save_cur_col $_cur_col + if { $_alternate_setup } { + set _cur_col $tmp + } - if { ! $debug } { - return - } + if { $_alternate_setup } { + set tmp $_save_cur_row + } + set _save_cur_row $_cur_row + if { $_alternate_setup } { + set _cur_row $tmp + } - verbose -log "$arg" + if { ! $_alternate_setup } { + variable _rows + variable _cols + _setup $_rows $_cols + set _alternate_setup 1 } +} - # Accept some output from gdb and update the screen. WAIT_FOR is - # a regexp matching the line to wait for. Return 0 on timeout, 1 - # on success. - proc wait_for {wait_for} { - global gdb_prompt - variable _cur_col - variable _cur_row +# Initialize. +proc Term::_setup {rows cols} { + global stty_init + set stty_init "rows $rows columns $cols" + + variable _rows + variable _cols + variable _cur_col + variable _cur_row + variable _attrs + variable _resize_count + + set _rows $rows + set _cols $cols + set _cur_col 0 + set _cur_row 0 + set _resize_count 0 + _reset_attrs _attrs - set fn "wait_for" + _clear_lines 0 $_rows +} - set prompt_wait_for "(^|\\|)$gdb_prompt \$" - if { $wait_for == "" } { - set wait_for $prompt_wait_for +# Accept some output from gdb and update the screen. +# Return 1 if successful, or 0 if a timeout occurred. +proc Term::accept_gdb_output { {warn 1} } { + global expect_out + + set ctls "\x07\x08\x0a\x0d" + set esc "\x1b" + set re_ctls "\[$ctls\]" + set re_others "\[^$esc$ctls\]" + set have_esc 0 + gdb_expect { + -re ^$re_ctls { + scan $expect_out(0,string) %c val + set hexval [format "%02x" $val] + _log "wait_for: _ctl_0x${hexval}" + _ctl_0x${hexval} + } + -re "^$esc" { + _log "wait_for: ESC" + set have_esc 1 + } + -re "^$re_others+" { + _insert $expect_out(0,string) + } + + timeout { + # Assume a timeout means we somehow missed the + # expected result, and carry on. + warning "timeout in accept_gdb_output" + dump_screen + return 0 } + } - debug_tui_matching "$fn: regexp: '$wait_for'" + if { !$have_esc } { + return 1 + } - while 1 { - if { [accept_gdb_output] == 0 } { - return 0 - } + set re_csi [string_to_regexp "\["] + set have_csi 0 + gdb_expect { + -re "^(\[0-9a-zA-Z\])" { + _log "wait_for: unsupported escape" + error "unsupported escape" + } + -re "^(\[\\(\])(\[a-zA-Z\])" { + scan $expect_out(1,string) %c val + set hexval [format "%02x" $val] + set cmd $expect_out(2,string) + _esc_0x${hexval}_$cmd + } + -re "^(\[=>\])" { + scan $expect_out(1,string) %c val + set hexval [format "%02x" $val] + _esc_0x$hexval + } + -re "^$re_csi" { + _log "wait_for: CSI" + set have_csi 1 + } - # If the cursor appears just after the prompt, return. It - # isn't reliable to check this only after an insertion, - # because curses may make "unusual" redrawing decisions. - if {$wait_for == "$prompt_wait_for"} { - set prev [get_line $_cur_row $_cur_col] - } else { - set prev [get_line $_cur_row] - } - if {[regexp -- $wait_for $prev]} { - debug_tui_matching "$fn: match: '$prev'" - if {$wait_for == "$prompt_wait_for"} { - break - } - set wait_for $prompt_wait_for - debug_tui_matching "$fn: regexp prompt: '$wait_for'" - } else { - debug_tui_matching "$fn: mismatch: '$prev'" + timeout { + # Assume a timeout means we somehow missed the + # expected result, and carry on. + if { $warn } { + warning "timeout in accept_gdb_output following ESC" + dump_screen } + _insert "^\[" + return 0 } + } + if { !$have_csi } { return 1 } - # Accept some output from gdb and update the screen. Wait for the screen - # region X/Y/WIDTH/HEIGTH to matches REGEXP. Return 0 on timeout, 1 on - # success. - proc wait_for_region_contents {x y width height regexp} { - while 1 { - if { [accept_gdb_output] == 0 } { - return 0 - } - - if { [check_region_contents_p $x $y $width $height $regexp] } { - break + set re_csi_prefix {[?]} + set re_csi_args {[0-9;]} + set re_csi_cmd {[a-zA-Z@`]} + gdb_expect { + -re "^($re_csi_cmd)" { + set cmd $expect_out(1,string) + _log "wait_for: _csi_$cmd" + _csi_$cmd + } + -re "^($re_csi_args*)($re_csi_cmd)" { + set params [split $expect_out(1,string) ";"] + set cmd $expect_out(2,string) + _log "wait_for: _csi_$cmd <<<$params>>>" + _csi_$cmd {*}$params + } + -re "^($re_csi_prefix?)($re_csi_args*)($re_csi_cmd)" { + set prefix $expect_out(1,string) + set params [split $expect_out(2,string) ";"] + set cmd $expect_out(3,string) + scan $prefix %c val + set hexval [format "%02x" $val] + _log "wait_for: _csi_0x${hexval}_$cmd <<<$expect_out(1,string)>>>" + _csi_0x${hexval}_$cmd {*}$params + } + + timeout { + # Assume a timeout means we somehow missed the + # expected result, and carry on. + if { $warn } { + warning "timeout in accept_gdb_output following CSI" + dump_screen } + _insert "^\[\[" + return 0 } + } - return 1 + return 1 +} + +# Print arg using "verbose -log" if DEBUG_TUI_MATCHING == 1. +proc Term::debug_tui_matching { arg } { + set debug 0 + if { [info exists ::DEBUG_TUI_MATCHING] } { + set debug $::DEBUG_TUI_MATCHING } - # Setup the terminal with dimensions ROWSxCOLS, TERM=ansi, and execute - # BODY. - proc with_tuiterm {rows cols body} { - global env stty_init - save_vars {env(TERM) env(NO_COLOR) stty_init} { - setenv TERM ansi - setenv NO_COLOR "" - _setup $rows $cols + if { ! $debug } { + return + } - uplevel $body - } + verbose -log "$arg" +} + +# Accept some output from gdb and update the screen. WAIT_FOR is +# a regexp matching the line to wait for. Return 0 on timeout, 1 +# on success. +proc Term::wait_for {wait_for} { + global gdb_prompt + variable _cur_col + variable _cur_row + + set fn "wait_for" + + set prompt_wait_for "(^|\\|)$gdb_prompt \$" + if { $wait_for == "" } { + set wait_for $prompt_wait_for } - # Like ::clean_restart, but ensures that gdb starts in an - # environment where the TUI can work. ROWS and COLS are the size - # of the terminal. EXECUTABLE, if given, is passed to - # clean_restart. - proc clean_restart {rows cols {executable {}}} { - with_tuiterm $rows $cols { - save_vars { ::GDBFLAGS } { - # Make GDB not print the directory names. Use this setting to - # remove the differences in test runs due to varying directory - # names. - append ::GDBFLAGS " -ex \"set filename-display basename\"" + debug_tui_matching "$fn: regexp: '$wait_for'" - if {$executable == ""} { - ::clean_restart - } else { - ::clean_restart $executable - } - } + while 1 { + if { [accept_gdb_output] == 0 } { + return 0 + } - ::gdb_test_no_output "set pagination off" + # If the cursor appears just after the prompt, return. It + # isn't reliable to check this only after an insertion, + # because curses may make "unusual" redrawing decisions. + if {$wait_for == "$prompt_wait_for"} { + set prev [get_line $_cur_row $_cur_col] + } else { + set prev [get_line $_cur_row] } - } - # Generate prompt on TUIterm. - proc gen_prompt {} { - # Generate a prompt. - send_gdb "echo\n" + if { ![regexp -- $wait_for $prev] } { + debug_tui_matching "$fn: mismatch: '$prev'" + continue + } - # Drain the output before the prompt. - gdb_expect { - -re "echo\r\n" { + if {$wait_for == "$prompt_wait_for"} { + # We've detected that the cursor is just after the prompt. + # Now check that there's nothing else on the line. + set prev [get_line $_cur_row] + if { ![regexp -- "(^|\\|)$gdb_prompt +($|\\||\\+)" $prev] } { + debug_tui_matching "$fn: mismatch: '$prev'" + continue } } - # Interpret prompt using TUIterm. - wait_for "" - } + debug_tui_matching "$fn: match: '$prev'" - # Setup ready for starting the tui, but don't actually start it. - # Returns 1 on success, 0 if TUI tests should be skipped. - proc prepare_for_tui {} { - if { [is_remote host] } { - # In clean_restart, we're using "setenv TERM ansi", which has - # effect on build. If we have [is_remote host] == 0, so - # build == host, then it also has effect on host. But for - # [is_remote host] == 1, it has no effect on host. - return 0 + if {$wait_for == "$prompt_wait_for"} { + # Matched the prompt, we're done. + break } - if {![allow_tui_tests]} { + # Now try to match the prompt. + set wait_for $prompt_wait_for + debug_tui_matching "$fn: regexp prompt: '$wait_for'" + } + + return 1 +} + +# Accept some output from gdb and update the screen. Wait for the screen +# region X/Y/WIDTH/HEIGTH to matches REGEXP. Return 0 on timeout, 1 on +# success. +proc Term::wait_for_region_contents {x y width height regexp} { + while 1 { + if { [accept_gdb_output] == 0 } { return 0 } - gdb_test_no_output "set tui border-kind ascii" - gdb_test_no_output "maint set tui-resize-message on" - return 1 + if { [check_region_contents_p $x $y $width $height $regexp] } { + break + } } - # Start the TUI. Returns 1 on success, 0 if TUI tests should be - # skipped. - proc enter_tui {} { - if {![prepare_for_tui]} { + return 1 +} + +# Accept some output from gdb and update the screen. Wait for the current +# screen line to match REGEXP and cursor position POS, unless POS is empty. +# Return 0 on timeout, 1 on success. +proc Term::wait_for_line { regexp {pos ""} } { + variable _cur_row + variable _cur_col + variable _cols + + while 1 { + if { [accept_gdb_output] == 0 } { return 0 } - command_no_prompt_prefix "tui enable" - return 1 - } + if { ![check_region_contents_p 0 $_cur_row $_cols 1 $regexp] } { + continue + } - # Send the command CMD to gdb, then wait for a gdb prompt to be - # seen in the TUI. CMD should not end with a newline -- that will - # be supplied by this function. - proc command {cmd} { - global gdb_prompt - send_gdb "$cmd\n" - set str [string_to_regexp $cmd] - set str "(^|\\|)$gdb_prompt $str" - wait_for $str - } - - # As proc command, but don't wait for an initial prompt. This is used for - # initial terminal commands, where there's no prompt yet. - proc command_no_prompt_prefix {cmd} { - gen_prompt - command $cmd - } - - # Apply the attribute list in ATTRS to attributes array UPVAR_NAME. - # Return a string annotating the changed attributes. - proc apply_attrs { upvar_name attrs } { - set res "" - upvar $upvar_name var - foreach { attr val } $attrs { - if { $var($attr) != $val } { - append res "<$attr:$val>" - set var($attr) $val - } + if { $pos == "" || $_cur_col == $pos } { + break } + } - return $res + return 1 +} + +# In BODY, when using Term::with_tuiterm, use TERM instead of the default. + +proc Term::with_term { term body } { + save_vars { Term::_TERM } { + set Term::_TERM $term + uplevel $body } +} - # Return the text of screen line N. Lines are 0-based. If C is given, - # stop before column C. Columns are also zero-based. If ATTRS, annotate - # with attributes. - proc get_line_1 {n c attrs} { - variable _rows - # This can happen during resizing, if the cursor seems to - # temporarily be off-screen. - if {$n >= $_rows} { - return "" +# Setup the terminal with dimensions ROWSxCOLS, TERM=ansi, and execute +# BODY. +proc Term::with_tuiterm {rows cols body} { + global env stty_init + variable _TERM + save_vars {env(TERM) env(NO_COLOR) stty_init} { + if { $Term::_TERM != "" } { + setenv TERM $Term::_TERM + } elseif { [ishost *-*-*bsd*] } { + setenv TERM ansiw + } else { + setenv TERM ansi } + # Save active TERM variable. + set Term::_TERM $env(TERM) - set result "" - variable _cols - variable _chars - set c [_default $c $_cols] - set x 0 - if { $attrs } { - _reset_attrs line_attrs - } - while {$x < $c} { - if { $attrs } { - set char_attrs [lindex $_chars($x,$n) 1] - append result [apply_attrs line_attrs $char_attrs] + setenv NO_COLOR "" + _setup $rows $cols + + uplevel $body + } +} + +# Like ::clean_restart, but ensures that gdb starts in an +# environment where the TUI can work. ROWS and COLS are the size +# of the terminal. EXECUTABLE, if given, is passed to +# clean_restart. +proc Term::clean_restart {rows cols {executable {}}} { + with_tuiterm $rows $cols { + save_vars { ::GDBFLAGS } { + # Make GDB not print the directory names. Use this setting to + # remove the differences in test runs due to varying directory + # names. + append ::GDBFLAGS " -ex \"set filename-display basename\"" + + if {$executable == ""} { + ::clean_restart + } else { + ::clean_restart $executable } - append result [lindex $_chars($x,$n) 0] - incr x } - if { $attrs } { - _reset_attrs zero_attrs - set char_attrs [array get zero_attrs] - append result [apply_attrs line_attrs $char_attrs] + + ::gdb_test_no_output "set pagination off" + } +} + +# Generate prompt on TUIterm. +proc Term::gen_prompt {} { + # Generate a prompt. + send_gdb "echo\n" + + # Drain the output before the prompt. + gdb_expect { + -re "echo\r\n" { } - return $result } - # Return the text of screen line N, without attributes. Lines are - # 0-based. If C is given, stop before column C. Columns are also - # zero-based. - proc get_line {n {c ""} } { - return [get_line_1 $n $c 0] + # Interpret prompt using TUIterm. + wait_for "" +} + +# Setup ready for starting the tui, but don't actually start it. +# Returns 1 on success, 0 if TUI tests should be skipped. +proc Term::prepare_for_tui {} { + if { [is_remote host] } { + # In clean_restart, we're using "setenv TERM ansi", which has + # effect on build. If we have [is_remote host] == 0, so + # build == host, then it also has effect on host. But for + # [is_remote host] == 1, it has no effect on host. + return 0 } - # As get_line, but annotate with attributes. - proc get_line_with_attrs {n {c ""}} { - return [get_line_1 $n $c 1] + if {![allow_tui_tests]} { + return 0 } - # Get just the character at (X, Y). - proc get_char {x y} { - variable _chars - return [lindex $_chars($x,$y) 0] + gdb_test_no_output "set tui border-kind ascii" + gdb_test_no_output "maint set tui-resize-message on" + # When matching GDB output using Term::wait_for, the number of + # matching attempts in wait_for can be influenced by CLI styling. + # Disable it by default to avoid this. + gdb_test_no_output "set style enabled off" + return 1 +} + +# Start the TUI. Returns 1 on success, 0 if TUI tests should be +# skipped. +proc Term::enter_tui {} { + if {![prepare_for_tui]} { + return 0 } - # Get the entire screen as a string. - proc get_all_lines {} { - variable _rows - variable _cols - variable _chars + command_no_prompt_prefix "tui enable" + return 1 +} - set result "" - for {set y 0} {$y < $_rows} {incr y} { - for {set x 0} {$x < $_cols} {incr x} { - append result [lindex $_chars($x,$y) 0] - } - append result "\n" +# Send the command CMD to gdb, then wait for a gdb prompt to be +# seen in the TUI. CMD should not end with a newline -- that will +# be supplied by this function. +proc Term::command {cmd} { + global gdb_prompt + send_gdb "$cmd\n" + set str [string_to_regexp $cmd] + set str "(^|\\|)$gdb_prompt $str" + wait_for $str +} + +# As proc command, but don't wait for an initial prompt. This is used for +# initial terminal commands, where there's no prompt yet. +proc Term::command_no_prompt_prefix {cmd} { + gen_prompt + command $cmd +} + +# Apply the attribute list in ATTRS to attributes array UPVAR_NAME. +# Return a string annotating the changed attributes. +proc Term::apply_attrs { upvar_name attrs } { + set res "" + upvar $upvar_name var + foreach { attr val } $attrs { + if { $var($attr) != $val } { + append res "<$attr:$val>" + set var($attr) $val } + } - return $result + return $res +} + +# Return the text of screen line N. Lines are 0-based. Start at column +# X. If C is non-empty, stop before column C. Columns are also +# zero-based. If ATTRS, annotate with attributes. +proc Term::get_string {n x c {attrs 0}} { + variable _rows + # This can happen during resizing, if the cursor seems to + # temporarily be off-screen. + if {$n >= $_rows} { + return "" } - # Get the text just before the cursor. - proc get_current_line {} { - variable _cur_col - variable _cur_row - return [get_line $_cur_row $_cur_col] + set result "" + variable _cols + variable _chars + set c [_default $c $_cols] + if { $attrs } { + _reset_attrs line_attrs } + while {$x < $c} { + if { $attrs } { + set char_attrs [lindex $_chars($x,$n) 1] + append result [apply_attrs line_attrs $char_attrs] + } + append result [lindex $_chars($x,$n) 0] + incr x + } + if { $attrs } { + _reset_attrs zero_attrs + set char_attrs [array get zero_attrs] + append result [apply_attrs line_attrs $char_attrs] + } + return $result +} - # Helper function for check_box. Returns empty string if the box - # is found, description of why not otherwise. - proc _check_box {x y width height} { - set x2 [expr {$x + $width - 1}] - set y2 [expr {$y + $height - 1}] +# Return the text of screen line N. Lines are 0-based. Start at column +# X. If C is non-empty, stop before column C. Columns are also +# zero-based. Annotate with attributes. +proc Term::get_string_with_attrs { n x c } { + return [get_string $n $x $c 1] +} - verbose -log "_check_box x=$x, y=$y, x2=$x2, y2=$y2, width=$width, height=$height" +# Return the text of screen line N. Lines are 0-based. If C is +# non-empty, stop before column C. Columns are also zero-based. If +# ATTRS, annotate with attributes. +proc Term::get_line_1 {n c attrs} { + return [get_string $n 0 $c $attrs] +} - set c [get_char $x $y] - if {$c != "+"} { - return "ul corner is $c, not +" - } +# Return the text of screen line N, without attributes. Lines are +# 0-based. If C is given, stop before column C. Columns are also +# zero-based. +proc Term::get_line {n {c ""} } { + return [get_line_1 $n $c 0] +} - set c [get_char $x $y2] - if {$c != "+"} { - return "ll corner is $c, not +" - } +# As get_line, but annotate with attributes. +proc Term::get_line_with_attrs {n {c ""}} { + return [get_line_1 $n $c 1] +} - set c [get_char $x2 $y] - if {$c != "+"} { - return "ur corner is $c, not +" - } +# Get just the character at (X, Y). +proc Term::get_char {x y} { + variable _chars + return [lindex $_chars($x,$y) 0] +} - set c [get_char $x2 $y2] - if {$c != "+"} { - return "lr corner is $c, not +" - } +# Get the entire screen as a string. +proc Term::get_all_lines {} { + variable _rows + variable _cols + variable _chars - # Note we do not check the full horizonal borders of the box. - # The top will contain a title, and the bottom may as well, if - # it is overlapped by some other border. However, at most a - # title should appear as '+-VERY LONG TITLE-+', so we can - # check for the '+-' on the left, and '-+' on the right. - set c [get_char [expr {$x + 1}] $y] - if {$c != "-"} { - return "ul title padding is $c, not -" + set result "" + for {set y 0} {$y < $_rows} {incr y} { + for {set x 0} {$x < $_cols} {incr x} { + append result [lindex $_chars($x,$y) 0] } + append result "\n" + } - set c [get_char [expr {$x2 - 1}] $y] - if {$c != "-"} { - return "ul title padding is $c, not -" - } + return $result +} - # Now check the vertical borders. - for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} { - set c [get_char $x $i] - if {$c != "|"} { - return "left side $i is $c, not |" - } +# Get the text just before the cursor. +proc Term::get_current_line {} { + variable _cur_col + variable _cur_row + return [get_line $_cur_row $_cur_col] +} - set c [get_char $x2 $i] - if {$c != "|"} { - return "right side $i is $c, not |" - } - } +# Helper function for check_box. Returns empty string if the box +# is found, description of why not otherwise. +proc Term::_check_box {x y width height} { + set x2 [expr {$x + $width - 1}] + set y2 [expr {$y + $height - 1}] - return "" + verbose -log "_check_box x=$x, y=$y, x2=$x2, y2=$y2, width=$width, height=$height" + + set c [get_char $x $y] + if {$c != "+"} { + return "ul corner is $c, not +" } - # Check for a box at the given coordinates. - proc check_box {test_name x y width height} { - dump_box $x $y $width $height - set why [_check_box $x $y $width $height] - if {$why == ""} { - pass $test_name - } else { - fail "$test_name ($why)" - } + set c [get_char $x $y2] + if {$c != "+"} { + return "ll corner is $c, not +" } - # Wait until a box appears at the given coordinates. - proc wait_for_box {test_name x y width height} { - while 1 { - if { [accept_gdb_output] == 0 } { - return 0 - } + set c [get_char $x2 $y] + if {$c != "+"} { + return "ur corner is $c, not +" + } - set why [_check_box $x $y $width $height] - if {$why == ""} { - pass $test_name - break - } - } + set c [get_char $x2 $y2] + if {$c != "+"} { + return "lr corner is $c, not +" } - # Check whether the text contents of the terminal match the - # regular expression. Note that text styling is not considered. - proc check_contents {test_name regexp} { - dump_screen - set contents [get_all_lines] - gdb_assert {[regexp -- $regexp $contents]} $test_name + # Note we do not check the full horizonal borders of the box. + # The top will contain a title, and the bottom may as well, if + # it is overlapped by some other border. However, at most a + # title should appear as '+-VERY LONG TITLE-+', so we can + # check for the '+-' on the left, and '-+' on the right. + set c [get_char [expr {$x + 1}] $y] + if {$c != "-"} { + return "ul title padding is $c, not -" } - # As check_contents, but check that the text contents of the terminal does - # not match the regular expression. - proc check_contents_not {test_name regexp} { - dump_screen - set contents [get_all_lines] - gdb_assert {![regexp -- $regexp $contents]} $test_name + set c [get_char [expr {$x2 - 1}] $y] + if {$c != "-"} { + return "ul title padding is $c, not -" } - # Get the region of the screen described by X, Y, WIDTH, and - # HEIGHT, and separate the lines using SEP. If ATTRS is true then - # include attribute information in the output. - proc get_region { x y width height sep { attrs false } } { - variable _chars + # Now check the vertical borders. + for {set i [expr {$y + 1}]} {$i < $y2 - 1} {incr i} { + set c [get_char $x $i] + if {$c != "|"} { + return "left side $i is $c, not |" + } - if { $attrs } { - _reset_attrs region_attrs + set c [get_char $x2 $i] + if {$c != "|"} { + return "right side $i is $c, not |" } + } - # Grab the contents of the box, join each line together - # using $sep. - set result "" - for {set yy $y} {$yy < [expr {$y + $height}]} {incr yy} { - if {$yy > $y} { - # Add the end of line sequence only if this isn't the - # first line. - append result $sep - } - for {set xx $x} {$xx < [expr {$x + $width}]} {incr xx} { - if { $attrs } { - set char_attrs [lindex $_chars($xx,$yy) 1] - append result [apply_attrs region_attrs $char_attrs] - } + return "" +} - append result [get_char $xx $yy] - } +# Check for a box at the given coordinates. +proc Term::check_box {test_name x y width height} { + dump_box $x $y $width $height + set why [_check_box $x $y $width $height] + if {$why == ""} { + pass $test_name + } else { + fail "$test_name ($why)" + } +} + +# Wait until a box appears at the given coordinates. +proc Term::wait_for_box {test_name x y width height} { + while 1 { + if { [accept_gdb_output] == 0 } { + return 0 } - if { $attrs } { - _reset_attrs zero_attrs - set char_attrs [array get zero_attrs] - append result [apply_attrs region_attrs $char_attrs] + + set why [_check_box $x $y $width $height] + if {$why == ""} { + pass $test_name + break } - return $result } +} - # Check that the region of the screen described by X, Y, WIDTH, - # and HEIGHT match REGEXP. This is like check_contents except - # only part of the screen is checked. This can be used to check - # the contents within a box (though check_box_contents is a better - # choice for boxes with a border). Return 1 if check succeeded. - proc check_region_contents_p { x y width height regexp } { - variable _chars - dump_box $x $y $width $height +# Check whether the text contents of the terminal match the +# regular expression. Note that text styling is not considered. +proc Term::check_contents {test_name regexp} { + dump_screen + set contents [get_all_lines] + gdb_assert {[regexp -- $regexp $contents]} $test_name +} - # Now grab the contents of the box, join each line together - # with a '\r\n' sequence and match against REGEXP. - set result [get_region $x $y $width $height "\r\n"] - return [regexp -- $regexp $result] - } +# As check_contents, but check that the text contents of the terminal does +# not match the regular expression. +proc Term::check_contents_not {test_name regexp} { + dump_screen + set contents [get_all_lines] + gdb_assert {![regexp -- $regexp $contents]} $test_name +} - # Check that the region of the screen described by X, Y, WIDTH, - # and HEIGHT match REGEXP. As check_region_contents_p, but produce - # a pass/fail message. - proc check_region_contents { test_name x y width height regexp } { - set ok [check_region_contents_p $x $y $width $height $regexp] - gdb_assert {$ok} $test_name - } +# Get the region of the screen described by X, Y, WIDTH, and +# HEIGHT, and separate the lines using SEP. If ATTRS is true then +# include attribute information in the output. +proc Term::get_region { x y width height sep { attrs false } } { + variable _chars - # Check the contents of a box on the screen. This is a little - # like check_contents, but doesn't check the whole screen - # contents, only the contents of a single box. This procedure - # includes (effectively) a call to check_box to ensure there is a - # box where expected, if there is then the contents of the box are - # matched against REGEXP. - proc check_box_contents {test_name x y width height regexp} { - variable _chars + if { $attrs } { + _reset_attrs region_attrs + } - dump_box $x $y $width $height - set why [_check_box $x $y $width $height] - if {$why != ""} { - fail "$test_name (box check: $why)" - return + # Grab the contents of the box, join each line together + # using $sep. + set result "" + for {set yy $y} {$yy < $y + $height} {incr yy} { + if {$yy > $y} { + # Add the end of line sequence only if this isn't the + # first line. + append result $sep } + for {set xx $x} {$xx < $x + $width} {incr xx} { + if { $attrs } { + set char_attrs [lindex $_chars($xx,$yy) 1] + append result [apply_attrs region_attrs $char_attrs] + } - check_region_contents $test_name [expr {$x + 1}] [expr {$y + 1}] \ - [expr {$width - 2}] [expr {$height - 2}] $regexp + append result [get_char $xx $yy] + } + } + if { $attrs } { + _reset_attrs zero_attrs + set char_attrs [array get zero_attrs] + append result [apply_attrs region_attrs $char_attrs] } + return $result +} - # A debugging function to dump the current screen, with line - # numbers. If ATTRS, annotate with attributes. - proc dump_screen { {attrs 0} } { - variable _rows - variable _cols - variable _cur_row - variable _cur_col +# Check that the region of the screen described by X, Y, WIDTH, +# and HEIGHT match REGEXP. This is like check_contents except +# only part of the screen is checked. This can be used to check +# the contents within a box (though check_box_contents is a better +# choice for boxes with a border). Return 1 if check succeeded. +proc Term::check_region_contents_p { x y width height regexp } { + variable _chars + dump_box $x $y $width $height - verbose -log "Screen Dump (size $_cols columns x $_rows rows, cursor at column $_cur_col, row $_cur_row):" + # Now grab the contents of the box, join each line together + # with a '\r\n' sequence and match against REGEXP. + set result [get_region $x $y $width $height "\r\n"] + return [regexp -- $regexp $result] +} - for {set y 0} {$y < $_rows} {incr y} { - set fmt [format %5d $y] - verbose -log "$fmt [get_line_1 $y "" $attrs]" - } +# Check that the region of the screen described by X, Y, WIDTH, +# and HEIGHT match REGEXP. As check_region_contents_p, but produce +# a pass/fail message. +proc Term::check_region_contents { test_name x y width height regexp } { + set ok [check_region_contents_p $x $y $width $height $regexp] + gdb_assert {$ok} $test_name +} + +# Check the contents of a box on the screen. This is a little +# like check_contents, but doesn't check the whole screen +# contents, only the contents of a single box. This procedure +# includes (effectively) a call to check_box to ensure there is a +# box where expected, if there is then the contents of the box are +# matched against REGEXP. +proc Term::check_box_contents {test_name x y width height regexp} { + variable _chars + + dump_box $x $y $width $height + set why [_check_box $x $y $width $height] + if {$why != ""} { + fail "$test_name (box check: $why)" + return } - # As dump_screen, but with attributes annotation. - proc dump_screen_with_attrs {} { - return [dump_screen 1] + check_region_contents $test_name [expr {$x + 1}] [expr {$y + 1}] \ + [expr {$width - 2}] [expr {$height - 2}] $regexp +} + +# A debugging function to dump the current screen, with line +# numbers. If ATTRS, annotate with attributes. +proc Term::dump_screen { {attrs 0} } { + variable _rows + variable _cols + variable _cur_row + variable _cur_col + + verbose -log "Screen Dump (size $_cols columns x $_rows rows, cursor at column $_cur_col, row $_cur_row):" + + for {set y 0} {$y < $_rows} {incr y} { + set fmt [format %5d $y] + verbose -log "$fmt [get_line_1 $y {} $attrs]" } +} - # A debugging function to dump a box from the current screen, with line - # numbers. - proc dump_box { x y width height } { - verbose -log "Box Dump ($width x $height) @ ($x, $y):" - set region [get_region $x $y $width $height "\n"] - set lines [split $region "\n"] - set nr $y - foreach line $lines { - set fmt [format %5d $nr] - verbose -log "$fmt $line" - incr nr - } +# As dump_screen, but with attributes annotation. +proc Term::dump_screen_with_attrs {} { + return [dump_screen 1] +} + +# A debugging function to dump a box from the current screen, with line +# numbers. +proc Term::dump_box { x y width height } { + verbose -log "Box Dump ($width x $height) @ ($x, $y):" + set region [get_region $x $y $width $height "\n"] + set lines [split $region "\n"] + set nr $y + foreach line $lines { + set fmt [format %5d $nr] + verbose -log "$fmt $line" + incr nr } +} - # Resize the terminal. - proc _do_resize {rows cols} { - variable _chars - variable _rows - variable _cols +# Resize the terminal. +proc Term::_do_resize {rows cols} { + variable _chars + variable _rows + variable _cols - set old_rows [expr {min ($_rows, $rows)}] - set old_cols [expr {min ($_cols, $cols)}] + set old_rows [expr {min ($_rows, $rows)}] + set old_cols [expr {min ($_cols, $cols)}] - # Copy locally. - array set local_chars [array get _chars] - unset _chars + # Copy locally. + array set local_chars [array get _chars] + unset _chars - set _rows $rows - set _cols $cols - _clear_lines 0 $_rows + set _rows $rows + set _cols $cols + _clear_lines 0 $_rows - for {set x 0} {$x < $old_cols} {incr x} { - for {set y 0} {$y < $old_rows} {incr y} { - set _chars($x,$y) $local_chars($x,$y) - } + for {set x 0} {$x < $old_cols} {incr x} { + for {set y 0} {$y < $old_rows} {incr y} { + set _chars($x,$y) $local_chars($x,$y) } } +} - proc resize {rows cols {wait_for_msg 1}} { - variable _rows - variable _cols - variable _resize_count +proc Term::resize {rows cols {wait_for_msg 1}} { + variable _rows + variable _cols + variable _resize_count - # expect handles each argument to stty separately. This means - # that gdb will see SIGWINCH twice. Rather than rely on this - # behavior (which, after all, could be changed), we make it - # explicit here. This also simplifies waiting for the redraw. - _do_resize $rows $_cols - stty rows $_rows < $::gdb_tty_name - if { $wait_for_msg } { - wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}" - } - incr _resize_count - _do_resize $_rows $cols - stty columns $_cols < $::gdb_tty_name - if { $wait_for_msg } { - wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}" - } - incr _resize_count - } + # expect handles each argument to stty separately. This means + # that gdb will see SIGWINCH twice. Rather than rely on this + # behavior (which, after all, could be changed), we make it + # explicit here. This also simplifies waiting for the redraw. + _do_resize $rows $_cols + stty rows $_rows < $::gdb_tty_name + if { $wait_for_msg } { + wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}" + } + incr _resize_count + _do_resize $_rows $cols + stty columns $_cols < $::gdb_tty_name + if { $wait_for_msg } { + wait_for "@@ resize done $_resize_count, size = ${_cols}x${rows}" + } + incr _resize_count } |