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