Initial implementation of Debugger Adapter Protocol

The Debugger Adapter Protocol is a JSON-RPC protocol that IDEs can use
to communicate with debuggers.  You can find more information here:

    https://microsoft.github.io/debug-adapter-protocol/

Frequently this is implemented as a shim, but it seemed to me that GDB
could implement it directly, via the Python API.  This patch is the
initial implementation.

DAP is implemented as a new "interp".  This is slightly weird, because
it doesn't act like an ordinary interpreter -- for example it doesn't
implement a command syntax, and doesn't use GDB's ordinary event loop.
However, this seemed like the best approach overall.

To run GDB in this mode, use:

    gdb -i=dap

The DAP code will accept JSON-RPC messages on stdin and print
responses to stdout.  GDB redirects the inferior's stdout to a new
pipe so that output can be encapsulated by the protocol.

The Python code uses multiple threads to do its work.  Separate
threads are used for reading JSON from the client and for writing JSON
to the client.  All GDB work is done in the main thread.  (The first
implementation used asyncio, but this had some limitations, and so I
rewrote it to use threads instead.)

This is not a complete implementation of the protocol, but it does
implement enough to demonstrate that the overall approach works.

There is a rudimentary test suite.  It uses a JSON parser written in
pure Tcl.  This parser is under the same license as Tcl itself, so I
felt it was acceptable to simply import it into the tree.

There is also a bit of documentation -- just documenting the new
interpreter name.

1 files changed, 343 insertions, 0 deletions

diff --git a/gdb/testsuite/lib/dap-support.exp b/gdb/testsuite/lib/dap-support.exp
new file mode 100644
index 0000000..adf332c
--- /dev/null
+++ b/gdb/testsuite/lib/dap-support.exp
@@ -0,0 +1,343 @@
+# Copyright 2022 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+# The JSON parser.
+load_lib ton.tcl
+
+# The sequence number for the next DAP request.  This is used by the
+# automatic sequence-counting code below.  It is reset each time GDB
+# is restarted.
+set dap_seq 1
+
+# Start gdb using the DAP interpreter.
+proc dap_gdb_start {} {
+    # Keep track of the number of times GDB has been launched.
+    global gdb_instances
+    incr gdb_instances
+
+    gdb_stdin_log_init
+
+    global GDBFLAGS stty_init
+    save_vars { GDBFLAGS stty_init } {
+	set stty_init "-echo raw"
+	set logfile [standard_output_file "dap.log.$gdb_instances"]
+	append GDBFLAGS " -iex \"set debug dap-log-file $logfile\" -q -i=dap"
+	set res [gdb_spawn]
+	if {$res != 0} {
+	    return $res
+	}
+    }
+
+    # Reset the counter.
+    set ::dap_seq 1
+
+    return 0
+}
+
+# A helper for dap_to_ton that decides if the list L is a JSON object
+# or if it is an array.
+proc _dap_is_obj {l} {
+    if {[llength $l] % 2 != 0} {
+	return 0
+    }
+    foreach {key value} $l {
+	if {![string is alpha $key]} {
+	    return 0
+	}
+    }
+    return 1
+}
+
+# The "TON" format is a bit of a pain to write by hand, so this proc
+# can be used to convert an ordinary Tcl list into TON by guessing at
+# the correct forms to use.  This can't be used in all cases, because
+# Tcl can't really differentiate between literal forms.  For example,
+# there's no way to decide if "true" should be a string or the literal
+# true.
+#
+# JSON objects must be passed in a particular form here -- as a list
+# with an even number of elements, alternating keys and values.  Each
+# key must consist only of letters, no digits or other non-letter
+# characters.  Note that this is compatible with the Tcl 'dict'
+# representation.
+proc dap_to_ton {obj} {
+    if {[string is list $obj] && [llength $obj] > 1} {
+	if {[_dap_is_obj $obj]} {
+	    set result o
+	    foreach {key value} $obj {
+		lappend result $key \[[dap_to_ton $value]\]
+	    }
+	} else {
+	    set result a
+	    foreach val $obj {
+		lappend result \[[dap_to_ton $val]\]
+	    }
+	}
+    } elseif {[string is entier $obj]} {
+	set result [list i $obj]
+    } elseif {[string is double $obj]} {
+	set result [list d $obj]
+    } elseif {$obj == "true" || $obj == "false" || $obj == "null"} {
+	set result [list l $obj]
+    } else {
+	set result [list s $obj]
+    }
+    return $result
+}
+
+# Format the object OBJ, in TON format, as JSON and send it to gdb.
+proc dap_send_ton {obj} {
+    set json [namespace eval ton::2json $obj]
+    # FIXME this is wrong for non-ASCII characters.
+    set len [string length $json]
+    verbose ">>> $json"
+    send_gdb "Content-Length: $len\r\n\r\n$json"
+}
+
+# Send a DAP request to gdb.  COMMAND is the request's "command"
+# field, and OBJ is the "arguments" field.  If OBJ is empty, it is
+# omitted.  The sequence number of the request is automatically added,
+# and this is also the return value.  OBJ is assumed to already be in
+# TON form.
+proc dap_send_request {command {obj {}}} {
+    # We can construct this directly as a TON object.
+    set result $::dap_seq
+    incr ::dap_seq
+    set req [format {o seq [i %d] type [s request] command [%s]} \
+		 $result [list s $command]]
+    if {$obj != ""} {
+	append req " arguments \[$obj\]"
+    }
+    dap_send_ton $req
+    return $result
+}
+
+# Read a JSON response from gdb.  This will return a TON object on
+# success, or throw an exception on error.
+proc dap_read_json {} {
+    set length ""
+    gdb_expect {
+	-re "^Content-Length: (\[0-9\]+)\r\n" {
+	    set length $expect_out(1,string)
+	    exp_continue
+	}
+	-re "^(\[^\r\n\]+)\r\n" {
+	    # Any other header field.
+	    exp_continue
+	}
+	-re "^\r\n" {
+	    # Done.
+	}
+	timeout {
+	    error "timeout reading json header"
+	}
+	eof {
+	    error "eof reading json header"
+	}
+    }
+
+    if {$length == ""} {
+	error "didn't find content-length"
+    }
+
+    set json ""
+    while {$length > 0} {
+	# Tcl only allows up to 255 characters in a {} expression in a
+	# regexp, so we may need to read in chunks.
+	set this_len [expr {min ($length, 255)}]
+	gdb_expect {
+	    -re "^.{$this_len}" {
+		append json $expect_out(0,string)
+	    }
+	    timeout {
+		error "timeout reading json body"
+	    }
+	    eof {
+		error "eof reading json body"
+	    }
+	}
+	incr length -$this_len
+    }
+
+    return [ton::json2ton $json]
+}
+
+# Read a sequence of JSON objects from gdb, until a response object is
+# seen.  If the response object has the request sequence number NUM,
+# and is for command CMD, return a list of two elements: the response
+# object and a list of any preceding events, in the order they were
+# emitted.  The objects are in TON format.  If a response object is
+# seen but has the wrong sequence number or command, throw an
+# exception
+proc dap_read_response {cmd num} {
+    set result {}
+    while 1 {
+	set obj [dap_read_json]
+	set d [namespace eval ton::2dict $obj]
+	if {[dict get $d type] == "response"} {
+	    if {[dict get $d request_seq] != $num} {
+		error "saw wrong request_seq in $obj"
+	    } elseif {[dict get $d command] != $cmd} {
+		error "saw wrong command in $obj"
+	    } else {
+		return [list $obj $result]
+	    }
+	} else {
+	    lappend result $obj
+	}
+    }
+}
+
+# A wrapper for dap_send_request and dap_read_response.  This sends a
+# request to gdb and returns the result.  NAME is used to issue a pass
+# or fail; on failure, this always returns an empty string.
+proc dap_request_and_response {name command {obj {}}} {
+    set result {}
+    if {[catch {
+	set seq [dap_send_request $command $obj]
+	set result [dap_read_response $command $seq]
+    } text]} {
+	verbose "reason: $text"
+	fail $name
+    } else {
+	pass $name
+    }
+    return $result
+}
+
+# Like dap_request_and_response, but also checks that the response
+# indicates success.
+proc dap_check_request_and_response {name command {obj {}}} {
+    set result [dap_request_and_response $name $command $obj]
+    if {$result == ""} {
+	return ""
+    }
+    set d [namespace eval ton::2dict [lindex $result 0]]
+    if {[dict get $d success] != "true"} {
+	verbose "request failure: $result"
+	fail "$name success"
+	return ""
+    }
+    pass "$name success"
+    return $result
+}
+
+# Start gdb, send a DAP initialization request and return the
+# response.  This approach lets the caller check the feature list, if
+# desired.  Callers not caring about this should probably use
+# dap_launch.  Returns the empty string on failure.  NAME is used as
+# the test name.
+proc dap_initialize {name} {
+    if {[dap_gdb_start]} {
+	return ""
+    }
+    return [dap_check_request_and_response $name initialize]
+}
+
+# Start gdb, send a DAP initialize request, and then a launch request
+# specifying FILE as the program to use for the inferior.  Returns the
+# empty string on failure, or the response object from the launch
+# request.  After this is called, gdb will be ready to accept
+# breakpoint requests.  NAME is used as the test name.  It has a
+# reasonable default but can be overridden in case a test needs to
+# launch gdb more than once.
+proc dap_launch {file {name startup}} {
+    if {[dap_initialize "$name - initialize"] == ""} {
+	return ""
+    }
+    return [dap_check_request_and_response "$name - launch" launch \
+		[format {o program [%s]} \
+		     [list s [standard_output_file $file]]]]
+}
+
+# Cleanly shut down gdb.  NAME is used as the test name.
+proc dap_shutdown {{name shutdown}} {
+    dap_check_request_and_response $name disconnect
+}
+
+# Search the event list EVENTS for an output event matching the regexp
+# RX.  Pass the test NAME if found, fail if not.
+proc dap_search_output {name rx events} {
+    foreach event $events {
+	set d [namespace eval ton::2dict $event]
+	if {[dict get $d type] != "event"
+	    || [dict get $d event] != "output"} {
+	    continue
+	}
+	if {[regexp $rx [dict get $d body output]]} {
+	    pass $name
+	    return
+	}
+    }
+    fail $name
+}
+
+# Check that OBJ (a single TON object) has values that match the
+# key/value pairs given in ARGS.  NAME is used as the test name.
+proc dap_match_values {name obj args} {
+    set d [namespace eval ton::2dict $obj]
+    foreach {key value} $args {
+	if {[eval dict get [list $d] $key] != $value} {
+	    fail "$name (checking $key)"
+	    return ""
+	}
+    }
+    pass $name
+}
+
+# A helper for dap_read_event that reads events, looking for one
+# matching TYPE.
+proc _dap_read_event {type} {
+    while 1 {
+	# We don't do any extra error checking here for the time
+	# being; we'll just get a timeout thrown instead.
+	set obj [dap_read_json]
+	set d [namespace eval ton::2dict $obj]
+	if {[dict get $d type] == "event"
+	    && [dict get $d event] == $type} {
+	    return $obj
+	}
+    }
+}
+
+# Read JSON objects looking for an event whose "event" field is TYPE.
+# NAME is used as the test name; it defaults to TYPE.  Extra arguments
+# are used to check fields of the event; the arguments alternate
+# between a field name (in "dict get" form) and its expected value.
+# Returns the TON object for the chosen event, or empty string on
+# error.
+proc dap_read_event {name type args} {
+    if {$name == ""} {
+	set name $type
+    }
+
+    if {[catch {_dap_read_event $type} result]} {
+	fail $name
+	return ""
+    }
+
+    eval dap_match_values [list $name $result] $args
+
+    return $result
+}
+
+# A convenience function to extract the breakpoint number when a new
+# breakpoint is created.  OBJ is an object as returned by
+# dap_check_request_and_response.
+proc dap_get_breakpoint_number {obj} {
+    set d [namespace eval ton::2dict [lindex $obj 0]]
+    set bplist [dict get $d body breakpoints]
+    return [dict get [lindex $bplist 0] id]
+}