1# Copyright (C) 2009-2020 Free Software Foundation, Inc. 2 3# This program is free software; you can redistribute it and/or modify 4# it under the terms of the GNU General Public License as published by 5# the Free Software Foundation; either version 3 of the License, or 6# (at your option) any later version. 7# 8# This program is distributed in the hope that it will be useful, 9# but WITHOUT ANY WARRANTY; without even the implied warranty of 10# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11# GNU General Public License for more details. 12# 13# You should have received a copy of the GNU General Public License 14# along with GCC; see the file COPYING3. If not see 15# <http://www.gnu.org/licenses/>. 16 17# Utility for testing variable values using gdb, invoked via dg-final. 18# Call pass if variable has the desired value, otherwise fail. 19# 20# Argument 0 is the line number on which to put a breakpoint 21# Argument 1 is the name of the variable to be checked 22# possibly prefixed with type: to get the type of the variable 23# instead of the value of the variable (the default). 24# Argument 2 is the expected value (or type) of the variable 25# When asking for the value, the expected value is produced 26# calling print on it in gdb. When asking for the type it is 27# the literal string with extra whitespace removed. 28# Argument 3 handles expected failures and the like 29proc gdb-test { useline args } { 30 if { ![isnative] || [is_remote target] } { return } 31 32 if { [llength $args] >= 4 } { 33 switch [dg-process-target [lindex $args 3]] { 34 "S" { } 35 "N" { return } 36 "F" { setup_xfail "*-*-*" } 37 "P" { } 38 } 39 } 40 41 # This assumes that we are three frames down from dg-test, and that 42 # it still stores the filename of the testcase in a local variable "name". 43 # A cleaner solution would require a new DejaGnu release. 44 upvar 2 name testcase 45 upvar 2 prog prog 46 47 # The command to run on the variable 48 set arg1 [lindex $args 1] 49 if { [string equal -length 5 "type:" $arg1] == 1 } { 50 set command "ptype" 51 set var [string range $arg1 5 end] 52 } else { 53 set command "print" 54 set var $arg1 55 } 56 57 set line [lindex $args 0] 58 if { [string range $line 0 0] == "@" } { 59 set line [string range $line 1 end] 60 } else { 61 set line [get-absolute-line $useline $line] 62 } 63 64 set gdb_name $::env(GUALITY_GDB_NAME) 65 set testname "$testcase line $line [lindex $args 1] == [lindex $args 2]" 66 set output_file "[file rootname [file tail $prog]].exe" 67 set cmd_file "[file rootname [file tail $prog]].gdb" 68 69 set fd [open $cmd_file "w"] 70 puts $fd "break $line" 71 puts $fd "run" 72 puts $fd "$command $var" 73 if { $command == "print" } { 74 # For values, let gdb interpret them by printing them. 75 puts $fd "print [lindex $args 2]" 76 } else { 77 # Since types can span multiple lines, we need an end marker. 78 puts $fd "echo TYPE_END\\n" 79 } 80 puts $fd "quit" 81 close $fd 82 83 send_log "Spawning: $gdb_name -nx -nw -quiet -batch -x $cmd_file ./$output_file\n" 84 set res [remote_spawn target "$gdb_name -nx -nw -quiet -batch -x $cmd_file ./$output_file"] 85 if { $res < 0 || $res == "" } { 86 unsupported "$testname" 87 file delete $cmd_file 88 return 89 } 90 91 remote_expect target [timeout_value] { 92 # Too old GDB 93 -re "Unhandled dwarf expression|Error in sourced command file|<unknown type in " { 94 unsupported "$testname" 95 remote_close target 96 file delete $cmd_file 97 return 98 } 99 # print var; print expected 100 -re {[\n\r]\$1 = ([^\n\r]*)[\n\r]+\$2 = ([^\n\r]*)[\n\r]} { 101 set first $expect_out(1,string) 102 set second $expect_out(2,string) 103 if { $first == $second } { 104 pass "$testname" 105 } else { 106 # We need the -- to disambiguate $first from an option, 107 # as it may be negative. 108 send_log -- "$first != $second\n" 109 fail "$testname" 110 } 111 remote_close target 112 file delete $cmd_file 113 return 114 } 115 # ptype var; 116 -re {[\n\r]type = (.*)[\n\r][\n\r]TYPE_END[\n\r]} { 117 set type $expect_out(1,string) 118 # Squash all extra whitespace/newlines that gdb might use for 119 # "pretty printing" into one so result is just one line. 120 regsub -all {[\n\r\t ]+} $type " " type 121 # Old gdb might output "long int" instead of just "long" 122 # and "short int" instead of just "short". Canonicalize. 123 regsub -all {\mlong int\M} $type "long" type 124 regsub -all {\mshort int\M} $type "short" type 125 set expected [lindex $args 2] 126 if { $type == $expected } { 127 pass "$testname" 128 } else { 129 send_log -- "$type != $expected\n" 130 fail "$testname" 131 } 132 remote_close target 133 file delete $cmd_file 134 return 135 } 136 timeout { 137 unsupported "$testname" 138 remote_close target 139 file delete $cmd_file 140 return 141 } 142 } 143 144 unsupported "$testname" 145 remote_close target 146 file delete $cmd_file 147 return 148} 149 150# Report the gdb path and version log the .log file 151# Argument 0 is the gdb path 152# Argument 1 is the location where gdb is used 153# 154proc report_gdb { gdb loc } { 155 if { [catch { exec which $gdb } msg] } { 156 send_log "gdb not found in $loc: $msg\n" 157 return 158 } 159 set gdb [exec which $gdb] 160 send_log "gdb used in $loc: $gdb\n" 161 162 send_log "gdb used in $loc: " 163 if { [catch { exec $gdb -v } gdb_version] } { 164 send_log "getting version failed:\n" 165 } else { 166 send_log "version:\n" 167 } 168 send_log -- "---\n$gdb_version\n---\n" 169} 170 171# Argument 0 is the option list. 172# Return the option list, ensuring that at least -Og is present. 173 174proc guality_minimal_options { args } { 175 set options [lindex $args 0] 176 foreach opt $options { 177 if { [regexp -- "-Og" $opt] } { 178 return $options 179 } 180 } 181 182 return [lappend options "-Og"] 183} 184