This is the mail archive of the
gdb-patches@sourceware.org
mailing list for the GDB project.
[PATCH, doc RFA] Add guile gdb command support
- From: Doug Evans <xdje42 at gmail dot com>
- To: gdb-patches at sourceware dot org, eliz at gnu dot org
- Date: Wed, 21 May 2014 12:28:16 -0700
- Subject: [PATCH, doc RFA] Add guile gdb command support
- Authentication-results: sourceware.org; auth=none
Hi.
This patch adds gdb command support for guile.
This patch assumes this patch has been applied:
https://sourceware.org/ml/gdb-patches/2014-05/msg00296.html
I had code in this patch to allow a user-provided completer function
to return one of the completion codes. But given this thread
I've temporarily removed this functionality until the bug is resolved.
https://sourceware.org/ml/gdb-patches/2014-05/msg00460.html
2014-05-21 Doug Evans <xdje42@gmail.com>
* Makefile.in (SUBDIR_GUILE_OBS): Add scm-cmd.o.
(SUBDIR_GUILE_SRCS): Add scm-cmd.c.
(scm-cmd.o): New rule.
* guile/guile-internal.h (gdbscm_user_error_p): Declare.
(gdbscm_parse_command_name): Declare.
(gdbscm_valid_command_class_p): Declare.
(gdbscm_initialize_commands): Declare.
* guile/guile.c (initialize_gdb_module): Call
gdbscm_initialize_commands.
* guile/lib/gdb.scm: Export command symbols.
* guile/lib/gdb/init.scm (%exception-keys): Add gdb:user-error.
(throw-user-error): New function.
* guile/scm-cmd.c: New file.
* guile/scm-exception.c (user_error_symbol): New static global.
(gdbscm_user_error_p): New function.
(gdbscm_initialize_exceptions): Set user_error_symbol.
testsuite/
* gdb.guile/scm-cmd.c: New file.
* gdb.guile/scm-cmd.exp: New file.
doc/
* guile.texi (Guile API): Add entry for Commands In Guile.
(Basic Guile) <parse-and-eval>: Add reference.
(Basic Guile) <string->argv>: Move definition to Commands In Guile.
(GDB Scheme Data Types): Mention <gdb:command> object.
(Commands In Guile): New node.
diff --git a/gdb/Makefile.in b/gdb/Makefile.in
index f2c16ec..a6d23fa 100644
--- a/gdb/Makefile.in
+++ b/gdb/Makefile.in
@@ -288,6 +288,7 @@ SUBDIR_GUILE_OBS = \
scm-auto-load.o \
scm-block.o \
scm-breakpoint.o \
+ scm-cmd.o \
scm-disasm.o \
scm-exception.o \
scm-frame.o \
@@ -311,6 +312,7 @@ SUBDIR_GUILE_SRCS = \
guile/scm-auto-load.c \
guile/scm-block.c \
guile/scm-breakpoint.c \
+ guile/scm-cmd.c \
guile/scm-disasm.c \
guile/scm-exception.c \
guile/scm-frame.c \
@@ -2270,6 +2272,10 @@ scm-breakpoint.o: $(srcdir)/guile/scm-breakpoint.c
$(COMPILE) $(srcdir)/guile/scm-breakpoint.c
$(POSTCOMPILE)
+scm-cmd.o: $(srcdir)/guile/scm-cmd.c
+ $(COMPILE) $(srcdir)/guile/scm-cmd.c
+ $(POSTCOMPILE)
+
scm-disasm.o: $(srcdir)/guile/scm-disasm.c
$(COMPILE) $(srcdir)/guile/scm-disasm.c
$(POSTCOMPILE)
diff --git a/gdb/doc/guile.texi b/gdb/doc/guile.texi
index 56d817e..52b0eec 100644
--- a/gdb/doc/guile.texi
+++ b/gdb/doc/guile.texi
@@ -141,6 +141,7 @@ from the Guile interactive prompt.
* Guile Pretty Printing API:: Pretty-printing values with Guile
* Selecting Guile Pretty-Printers:: How GDB chooses a pretty-printer
* Writing a Guile Pretty-Printer:: Writing a pretty-printer
+* Commands In Guile:: Implementing new commands in Guile
* Objfiles In Guile:: Object files in Guile
* Frames In Guile:: Accessing inferior stack frames from Guile
* Blocks In Guile:: Accessing blocks from Guile
@@ -292,16 +293,14 @@ Parse @var{expression} as an expression in the current language,
evaluate it, and return the result as a @code{<gdb:value>}.
@var{expression} must be a string.
-This function is useful when computing values.
+This function can be useful when implementing a new command
+(@pxref{Commands In Guile}), as it provides a way to parse the
+command's argument as an expression.
+It is also is useful when computing values.
For example, it is the only way to get the value of a
convenience variable (@pxref{Convenience Vars}) as a @code{<gdb:value>}.
@end deffn
-@deffn {Scheme Procedure} string->argv string
-Convert a string to a list of strings split up according to
-@value{GDBN}'s argv parsing rules.
-@end deffn
-
@node Guile Configuration
@subsubsection Guile Configuration
@cindex guile configuration
@@ -385,6 +384,9 @@ Return an unsorted list of names of properties.
@item <gdb:breakpoint>
@xref{Breakpoints In Guile}.
+@item <gdb:command>
+@xref{Commands In Guile}.
+
@item <gdb:exception>
@xref{Guile Exception Handling}.
@@ -1688,6 +1690,271 @@ my_library.so:
bar
@end smallexample
+@node Commands In Guile
+@subsubsection Commands In Guile
+
+@cindex commands in guile
+@cindex guile commands
+You can implement new @value{GDBN} CLI commands in Guile. A CLI
+command is defined with the @code{make-command!} Guile function.
+
+@c TODO: line length
+@deffn {Scheme Procedure} (make-command! name @r{[}#:invoke invoke{]} @r{[}#:command-class command-class@r{]} @r{[}#:completer-class completer{]} @r{[}#:prefix? prefix@r{]} @r{[}#:doc doc-string{]})
+
+@var{name} is the name of the command. If @var{name} consists of
+multiple words, then the initial words are looked for as prefix
+commands. In this case, if one of the prefix commands does not exist,
+an exception is raised.
+
+The result is the @code{<gdb:command>} object representing the command.
+
+The rest of the arguments are optional.
+
+@var{invoke} is a procedure of three arguments: @var{self}, @var{args}
+and @var{from-tty}. @var{self} is the @code{<gdb:command>} object
+representing the command.
+@var{args} is a string representing the arguments passed to the command,
+after leading and trailing whitespace has been stripped.
+@var{from-tty} is a boolean flag and specifies whether the command should
+consider itself to have been originated from the user invoking it interactively.
+If this function throws an exception, it is turned into a @value{GDBN}
+@code{error} call. Otherwise, the return value is ignored.
+
+@var{command-class} is one of the @samp{COMMAND_} constants
+defined below. This argument tells @value{GDBN} how to categorize the
+new command in the help system. The default is @code{COMMAND_NONE}.
+
+@var{completer} is either @code{#f}, one of the @samp{COMPLETE_} constants
+defined below, or a procedure, also defined below.
+This argument tells @value{GDBN} how to perform completion
+for this command.
+If not provided or if the value is @code{#f},
+then no completion is performed on the command.
+
+@var{prefix} is a boolean flag indicating whether the new
+command is a prefix command; sub-commands of this command may be
+registered.
+
+@var{doc-string} is help text for the new command.
+If no documentation string is provided, the default value ``This command is
+not documented.'' is used.
+@end deffn
+
+There is no support for multi-line commands.
+
+@deffn {Scheme Procedure} command? object
+Return @code{#t} if @var{object} is a @code{<gdb:command>} object.
+Otherwise return @code{#f}.
+@end deffn
+
+@cindex don't repeat Guile command
+@deffn {Scheme Procedure} dont-repeat
+By default, a @value{GDBN} command is repeated when the user enters a
+blank line at the command prompt. A command can suppress this
+behavior by invoking the @code{dont-repeat} function. This is similar
+to the user command @code{dont-repeat}, see @ref{Define, dont-repeat}.
+@end deffn
+
+@deffn {Scheme Procedure} string->argv string
+Convert a string to a list of strings split up according to
+@value{GDBN}'s argv parsing rules.
+It is recommended to use this for consistency.
+Arguments are separated by spaces and may be quoted.
+Example:
+
+@smallexample
+scheme@@(guile-user)> (string->argv "1 2\\ \\\"3 '4 \"5' \"6 '7\"")
+$1 = ("1" "2 \"3" "4 \"5" "6 '7")
+@end smallexample
+@end deffn
+
+@deffn {Scheme Procedure} throw-user-error message . args
+Throw a @code{gdb:user-error} exception.
+@var{message} is the error message as a format string, like the
+@var{fmt} argument to the @code{format} Scheme function.
+@xref{Formatted Output,,, guile, GNU Guile Reference Manual}.
+@var{args} are the optional arguments of @var{message}.
+
+This is used when the command detects a user error of some kind,
+say a bad command argument.
+
+@smallexample
+(gdb) guile (use-modules (gdb))
+(gdb) guile
+(make-command! "test-user-error"
+ #:command-class COMMAND_OBSCURE
+ #:invoke (lambda (self arg from-tty)
+ (throw-user-error "Bad argument ~a" arg)))
+end
+(gdb) test-user-error ugh
+ERROR: Bad argument ugh
+@end smallexample
+@end deffn
+
+@cindex completion of Guile commands
+@deffn completer self text word
+If the @var{completer} option to @code{make-command!} is a procedure,
+it takes three arguments: @var{self} which is the @code{<gdb:command>}
+object, and @var{text} and @var{word} which are both strings.
+@var{text} holds the complete command line up to the cursor's location.
+@var{word} holds the last word of the command line; this is computed
+using a word-breaking heuristic.
+
+All forms of completion are handled by this function, that is,
+the @key{TAB} and @key{M-?} key bindings (@pxref{Completion}),
+and the @code{complete} command (@pxref{Help, complete}).
+
+This procedure can return several kinds of values:
+
+@itemize @bullet
+@item
+If the return value is a list, the contents of the list are used as the
+completions. It is up to @var{completer} to ensure that the
+contents actually do complete the word. An empty list is
+allowed, it means that there were no completions available. Only
+string elements of the list are used; other elements in the
+list are ignored.
+
+@item
+If the return value is a <gdb:iterator> object, it is iterated over to
+obtain the completions. It is up to @code{completer-procedure} to ensure
+that the results actually do complete the word. Only
+string elements of the result are used; other elements in the
+sequence are ignored.
+
+@item
+All other results are treated as though there were no available
+completions.
+@end itemize
+@end deffn
+
+When a new command is registered, it must be declared as a member of
+some general class of commands. This is used to classify top-level
+commands in the on-line help system; note that prefix commands are not
+listed under their own category but rather that of their top-level
+command. The available classifications are represented by constants
+defined in the @code{gdb} module:
+
+@vtable @code
+@item COMMAND_NONE
+The command does not belong to any particular class. A command in
+this category will not be displayed in any of the help categories.
+
+@item COMMAND_RUNNING
+The command is related to running the inferior. For example,
+@code{start}, @code{step}, and @code{continue} are in this category.
+Type @kbd{help running} at the @value{GDBN} prompt to see a list of
+commands in this category.
+
+@item COMMAND_DATA
+The command is related to data or variables. For example,
+@code{call}, @code{find}, and @code{print} are in this category. Type
+@kbd{help data} at the @value{GDBN} prompt to see a list of commands
+in this category.
+
+@item COMMAND_STACK
+The command has to do with manipulation of the stack. For example,
+@code{backtrace}, @code{frame}, and @code{return} are in this
+category. Type @kbd{help stack} at the @value{GDBN} prompt to see a
+list of commands in this category.
+
+@item COMMAND_FILES
+This class is used for file-related commands. For example,
+@code{file}, @code{list} and @code{section} are in this category.
+Type @kbd{help files} at the @value{GDBN} prompt to see a list of
+commands in this category.
+
+@item COMMAND_SUPPORT
+This should be used for ``support facilities'', generally meaning
+things that are useful to the user when interacting with @value{GDBN},
+but not related to the state of the inferior. For example,
+@code{help}, @code{make}, and @code{shell} are in this category. Type
+@kbd{help support} at the @value{GDBN} prompt to see a list of
+commands in this category.
+
+@item COMMAND_STATUS
+The command is an @samp{info}-related command, that is, related to the
+state of @value{GDBN} itself. For example, @code{info}, @code{macro},
+and @code{show} are in this category. Type @kbd{help status} at the
+@value{GDBN} prompt to see a list of commands in this category.
+
+@item COMMAND_BREAKPOINTS
+The command has to do with breakpoints. For example, @code{break},
+@code{clear}, and @code{delete} are in this category. Type @kbd{help
+breakpoints} at the @value{GDBN} prompt to see a list of commands in
+this category.
+
+@item COMMAND_TRACEPOINTS
+The command has to do with tracepoints. For example, @code{trace},
+@code{actions}, and @code{tfind} are in this category. Type
+@kbd{help tracepoints} at the @value{GDBN} prompt to see a list of
+commands in this category.
+
+@item COMMAND_USER
+The command is a general purpose command for the user, and typically
+does not fit in one of the other categories.
+Type @kbd{help user-defined} at the @value{GDBN} prompt to see
+a list of commands in this category, as well as the list of gdb macros
+(@pxref{Sequences}).
+
+@item COMMAND_OBSCURE
+The command is only used in unusual circumstances, or is not of
+general interest to users. For example, @code{checkpoint},
+@code{fork}, and @code{stop} are in this category. Type @kbd{help
+obscure} at the @value{GDBN} prompt to see a list of commands in this
+category.
+
+@item COMMAND_MAINTENANCE
+The command is only useful to @value{GDBN} maintainers. The
+@code{maintenance} and @code{flushregs} commands are in this category.
+Type @kbd{help internals} at the @value{GDBN} prompt to see a list of
+commands in this category.
+@end vtable
+
+A new command can use a predefined completion function, either by
+specifying it via an argument at initialization, or by returning it
+from the @code{completer} procedure. These predefined completion
+constants are all defined in the @code{gdb} module:
+
+@vtable @code
+@item COMPLETE_NONE
+This constant means that no completion should be done.
+
+@item COMPLETE_FILENAME
+This constant means that filename completion should be performed.
+
+@item COMPLETE_LOCATION
+This constant means that location completion should be done.
+@xref{Specify Location}.
+
+@item COMPLETE_COMMAND
+This constant means that completion should examine @value{GDBN}
+command names.
+
+@item COMPLETE_SYMBOL
+This constant means that completion should be done using symbol names
+as the source.
+
+@item COMPLETE_EXPRESSION
+This constant means that completion should be done on expressions.
+Often this means completing on symbol names, but some language
+parsers also have support for completing on field names.
+@end vtable
+
+The following code snippet shows how a trivial CLI command can be
+implemented in Guile:
+
+@smallexample
+(gdb) guile
+(make-command! "hello-world"
+ #:command-class COMMAND_USER
+ #:doc "Greet the whole world."
+ #:invoke (lambda (self args from-tty) (display "Hello, World!\n")))
+end
+(gdb) hello-world
+Hello, World!
+@end smallexample
+
@node Objfiles In Guile
@subsubsection Objfiles In Guile
diff --git a/gdb/guile/guile-internal.h b/gdb/guile/guile-internal.h
index f95f092..7b3b902 100644
--- a/gdb/guile/guile-internal.h
+++ b/gdb/guile/guile-internal.h
@@ -304,6 +304,8 @@ extern char *gdbscm_exception_message_to_string (SCM exception);
extern excp_matcher_func gdbscm_memory_error_p;
+extern excp_matcher_func gdbscm_user_error_p;
+
extern SCM gdbscm_make_memory_error (const char *subr, const char *msg,
SCM args);
@@ -363,6 +365,15 @@ extern SCM bkscm_scm_from_block (const struct block *block,
extern const struct block *bkscm_scm_to_block
(SCM block_scm, int arg_pos, const char *func_name, SCM *excp);
+/* scm-cmd.c */
+
+extern char *gdbscm_parse_command_name (const char *name, SCM name_scm,
+ const char *func_name, int arg_pos,
+ struct cmd_list_element ***base_list,
+ struct cmd_list_element **start_list);
+
+extern int gdbscm_valid_command_class_p (int command_class);
+
/* scm-frame.c */
typedef struct _frame_smob frame_smob;
@@ -524,6 +535,7 @@ extern void gdbscm_initialize_arches (void);
extern void gdbscm_initialize_auto_load (void);
extern void gdbscm_initialize_blocks (void);
extern void gdbscm_initialize_breakpoints (void);
+extern void gdbscm_initialize_commands (void);
extern void gdbscm_initialize_disasm (void);
extern void gdbscm_initialize_exceptions (void);
extern void gdbscm_initialize_frames (void);
diff --git a/gdb/guile/guile.c b/gdb/guile/guile.c
index f2fd8d8..45c9d1d 100644
--- a/gdb/guile/guile.c
+++ b/gdb/guile/guile.c
@@ -537,6 +537,7 @@ initialize_gdb_module (void *data)
gdbscm_initialize_auto_load ();
gdbscm_initialize_blocks ();
gdbscm_initialize_breakpoints ();
+ gdbscm_initialize_commands ();
gdbscm_initialize_disasm ();
gdbscm_initialize_frames ();
gdbscm_initialize_iterators ();
diff --git a/gdb/guile/lib/gdb.scm b/gdb/guile/lib/gdb.scm
index f12769e..333101f 100644
--- a/gdb/guile/lib/gdb.scm
+++ b/gdb/guile/lib/gdb.scm
@@ -141,6 +141,33 @@
set-breakpoint-stop!
breakpoint-commands
+ ;; scm-cmd.c
+
+ make-command!
+ command?
+ command-valid?
+ dont-repeat
+
+ COMPLETE_NONE
+ COMPLETE_FILENAME
+ COMPLETE_LOCATION
+ COMPLETE_COMMAND
+ COMPLETE_SYMBOL
+ COMPLETE_EXPRESSION
+
+ COMMAND_NONE
+ COMMAND_RUNNING
+ COMMAND_DATA
+ COMMAND_STACK
+ COMMAND_FILES
+ COMMAND_SUPPORT
+ COMMAND_STATUS
+ COMMAND_BREAKPOINTS
+ COMMAND_TRACEPOINTS
+ COMMAND_OBSCURE
+ COMMAND_MAINTENANCE
+ COMMAND_USER
+
;; scm-disasm.c
arch-disassemble
@@ -449,4 +476,5 @@
orig-input-port
orig-output-port
orig-error-port
+ throw-user-error
)
diff --git a/gdb/guile/lib/gdb/init.scm b/gdb/guile/lib/gdb/init.scm
index 12ad67d..b709e0f 100644
--- a/gdb/guile/lib/gdb/init.scm
+++ b/gdb/guile/lib/gdb/init.scm
@@ -37,7 +37,8 @@
(define %exception-keys '(gdb:error
gdb:invalid-object-error
gdb:memory-error
- gdb:pp-type-error))
+ gdb:pp-type-error
+ gdb:user-error))
;; Printer for gdb exceptions, used when Scheme tries to print them directly.
@@ -171,3 +172,9 @@
(define-public (orig-input-port) %orig-input-port)
(define-public (orig-output-port) %orig-output-port)
(define-public (orig-error-port) %orig-error-port)
+
+;; Utility to throw gdb:user-error for use in writing gdb commands.
+;; The requirements for the arguments to throw is a bit obscure.
+
+(define-public (throw-user-error message . args)
+ (throw 'gdb:user-error #f message args))
diff --git a/gdb/guile/scm-cmd.c b/gdb/guile/scm-cmd.c
new file mode 100644
index 0000000..5fbc626
--- /dev/null
+++ b/gdb/guile/scm-cmd.c
@@ -0,0 +1,822 @@
+/* GDB commands implemented in Scheme.
+
+ Copyright (C) 2008-2014 Free Software Foundation, Inc.
+
+ This file is part of GDB.
+
+ 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/>. */
+
+/* See README file in this directory for implementation notes, coding
+ conventions, et.al. */
+
+#include "defs.h"
+#include <ctype.h>
+#include "exceptions.h"
+#include "charset.h"
+#include "gdbcmd.h"
+#include "cli/cli-decode.h"
+#include "completer.h"
+#include "guile-internal.h"
+
+/* The <gdb:command> smob. */
+
+typedef struct _command_smob
+{
+ /* This always appears first. */
+ gdb_smob base;
+
+ /* The corresponding gdb command object, or NULL if the command is
+ no longer installed. */
+ struct cmd_list_element *command;
+
+ /* A prefix command requires storage for a list of its sub-commands.
+ A pointer to this is passed to add_prefix_command, and to add_cmd
+ for sub-commands of that prefix. If this command is not a prefix
+ command, then this field is unused. */
+ struct cmd_list_element *sub_list;
+
+ /* The procedure to call to invoke the command.
+ (lambda (self arg from-tty) ...).
+ Its result is unspecified. */
+ SCM invoke;
+
+ /* Either #f, one of the COMPLETE_* constants, or a procedure to call to
+ perform command completion. Called as (lambda (self text word) ...). */
+ SCM complete;
+
+ /* The <gdb:command> object we are contained in, needed to protect/unprotect
+ the object since a reference to it comes from non-gc-managed space
+ (the command context pointer). */
+ SCM containing_scm;
+} command_smob;
+
+static const char command_smob_name[] = "gdb:command";
+
+/* The tag Guile knows the objfile smob by. */
+static scm_t_bits command_smob_tag;
+
+/* Keywords used by make-command!. */
+static SCM invoke_keyword;
+static SCM command_class_keyword;
+static SCM completer_class_keyword;
+static SCM prefix_p_keyword;
+static SCM doc_keyword;
+
+/* Struct representing built-in completion types. */
+struct cmdscm_completer
+{
+ /* Scheme symbol name. */
+ const char *name;
+ /* Completion function. */
+ completer_ftype *completer;
+};
+
+static const struct cmdscm_completer cmdscm_completers[] =
+{
+ { "COMPLETE_NONE", noop_completer },
+ { "COMPLETE_FILENAME", filename_completer },
+ { "COMPLETE_LOCATION", location_completer },
+ { "COMPLETE_COMMAND", command_completer },
+ { "COMPLETE_SYMBOL", make_symbol_completion_list_fn },
+ { "COMPLETE_EXPRESSION", expression_completer },
+};
+
+#define N_COMPLETERS (sizeof (cmdscm_completers) \
+ / sizeof (cmdscm_completers[0]))
+
+/* Administrivia for command smobs. */
+
+/* The smob "print" function for <gdb:command>. */
+
+static int
+cmdscm_print_command_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ command_smob *c_smob = (command_smob *) SCM_SMOB_DATA (self);
+
+ gdbscm_printf (port, "#<%s", command_smob_name);
+
+ gdbscm_printf (port, " %s",
+ c_smob->command != NULL
+ ? c_smob->command->name
+ : "{invalid}");
+
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to create a <gdb:command> object.
+ It's empty in the sense that a command still needs to be associated
+ with it. */
+
+static SCM
+cmdscm_make_command_smob (void)
+{
+ command_smob *c_smob = (command_smob *)
+ scm_gc_malloc (sizeof (command_smob), command_smob_name);
+ SCM c_scm;
+
+ c_smob->command = NULL;
+ c_smob->sub_list = NULL;
+ c_smob->invoke = SCM_BOOL_F;
+ c_smob->complete = SCM_BOOL_F;
+ c_scm = scm_new_smob (command_smob_tag, (scm_t_bits) c_smob);
+ c_smob->containing_scm = c_scm;
+ gdbscm_init_gsmob (&c_smob->base);
+
+ return c_scm;
+}
+
+/* Clear the COMMAND pointer in C_SMOB and unprotect the object from GC. */
+
+static void
+cmdscm_release_command (command_smob *c_smob)
+{
+ c_smob->command = NULL;
+ scm_gc_unprotect_object (c_smob->containing_scm);
+}
+
+/* Return non-zero if SCM is a command smob. */
+
+static int
+cmdscm_is_command (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (command_smob_tag, scm);
+}
+
+/* (command? scm) -> boolean */
+
+static SCM
+gdbscm_command_p (SCM scm)
+{
+ return scm_from_bool (cmdscm_is_command (scm));
+}
+
+/* Returns the <gdb:command> object in SELF.
+ Throws an exception if SELF is not a <gdb:command> object. */
+
+static SCM
+cmdscm_get_command_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (cmdscm_is_command (self), self, arg_pos, func_name,
+ command_smob_name);
+
+ return self;
+}
+
+/* Returns a pointer to the command smob of SELF.
+ Throws an exception if SELF is not a <gdb:command> object. */
+
+static command_smob *
+cmdscm_get_command_smob_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ SCM c_scm = cmdscm_get_command_arg_unsafe (self, arg_pos, func_name);
+ command_smob *c_smob = (command_smob *) SCM_SMOB_DATA (c_scm);
+
+ return c_smob;
+}
+
+/* Return non-zero if command C_SMOB is valid. */
+
+static int
+cmdscm_is_valid (command_smob *c_smob)
+{
+ return c_smob->command != NULL;
+}
+
+/* Returns a pointer to the command smob of SELF.
+ Throws an exception if SELF is not a valid <gdb:command> object. */
+
+static command_smob *
+cmdscm_get_valid_command_smob_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ command_smob *c_smob
+ = cmdscm_get_command_smob_arg_unsafe (self, arg_pos, func_name);
+
+ if (!cmdscm_is_valid (c_smob))
+ {
+ gdbscm_invalid_object_error (func_name, arg_pos, self,
+ _("<gdb:command>"));
+ }
+
+ return c_smob;
+}
+
+/* Scheme functions for GDB commands. */
+
+/* (command-valid? <gdb:command>) -> boolean
+ Returns #t if SELF is still valid. */
+
+static SCM
+gdbscm_command_valid_p (SCM self)
+{
+ command_smob *c_smob
+ = cmdscm_get_command_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_bool (cmdscm_is_valid (c_smob));
+}
+
+/* (dont-repeat cmd) -> unspecified
+ Scheme function which wraps dont_repeat. */
+
+static SCM
+gdbscm_dont_repeat (SCM self)
+{
+ /* We currently don't need anything from SELF, but still verify it. */
+ command_smob *c_smob
+ = cmdscm_get_valid_command_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ dont_repeat ();
+
+ return SCM_UNSPECIFIED;
+}
+
+/* The make-command! function. */
+
+/* Called if the gdb cmd_list_element is destroyed. */
+
+static void
+cmdscm_destroyer (struct cmd_list_element *self, void *context)
+{
+ command_smob *c_smob = (command_smob *) context;
+
+ cmdscm_release_command (c_smob);
+
+ /* We allocated the name, doc string, and perhaps the prefix name. */
+ xfree ((char *) self->name);
+ xfree (self->doc);
+ xfree (self->prefixname);
+}
+
+/* Called by gdb to invoke the command. */
+
+static void
+cmdscm_function (struct cmd_list_element *command, char *args, int from_tty)
+{
+ command_smob *c_smob/*obj*/ = (command_smob *) get_cmd_context (command);
+ SCM arg_scm, tty_scm, result;
+
+ gdb_assert (c_smob != NULL);
+
+ if (args == NULL)
+ args = "";
+ arg_scm = gdbscm_scm_from_string (args, strlen (args), host_charset (), 1);
+ if (gdbscm_is_exception (arg_scm))
+ error (_("Could not convert arguments to Scheme string."));
+
+ tty_scm = scm_from_bool (from_tty);
+
+ result = gdbscm_safe_call_3 (c_smob->invoke, c_smob->containing_scm,
+ arg_scm, tty_scm, gdbscm_user_error_p);
+
+ if (gdbscm_is_exception (result))
+ {
+ /* Don't print the stack if this was an error signalled by the command
+ itself. */
+ if (gdbscm_user_error_p (gdbscm_exception_key (result)))
+ {
+ char *msg = gdbscm_exception_message_to_string (result);
+
+ make_cleanup (xfree, msg);
+ error ("%s", msg);
+ }
+ else
+ {
+ gdbscm_print_gdb_exception (SCM_BOOL_F, result);
+ error (_("Error occurred in Scheme-implemented GDB command."));
+ }
+ }
+}
+
+/* Subroutine of cmdscm_completer to simplify it.
+ Print an error message indicating that COMPLETION is a bad completion
+ result. */
+
+static void
+cmdscm_bad_completion_result (const char *msg, SCM completion)
+{
+ SCM port = scm_current_error_port ();
+
+ scm_puts (msg, port);
+ scm_display (completion, port);
+ scm_newline (port);
+}
+
+/* Subroutine of cmdscm_completer to simplify it.
+ Validate COMPLETION and add to RESULT.
+ If an error occurs print an error message.
+ The result is a boolean indicating success. */
+
+static int
+cmdscm_add_completion (SCM completion, VEC (char_ptr) **result)
+{
+ char *item;
+ SCM except_scm;
+
+ if (!scm_is_string (completion))
+ {
+ /* Inform the user, but otherwise ignore the entire result. */
+ cmdscm_bad_completion_result (_("Bad text from completer: "),
+ completion);
+ return 0;
+ }
+
+ item = gdbscm_scm_to_string (completion, NULL, host_charset (), 1,
+ &except_scm);
+ if (item == NULL)
+ {
+ /* Inform the user, but otherwise ignore the entire result. */
+ gdbscm_print_gdb_exception (SCM_BOOL_F, except_scm);
+ return 0;
+ }
+
+ VEC_safe_push (char_ptr, *result, item);
+
+ return 1;
+}
+
+/* Called by gdb for command completion. */
+
+static VEC (char_ptr) *
+cmdscm_completer (struct cmd_list_element *command,
+ const char *text, const char *word)
+{
+ command_smob *c_smob/*obj*/ = (command_smob *) get_cmd_context (command);
+ SCM completer_result_scm;
+ SCM text_scm, word_scm, result_scm;
+ VEC (char_ptr) *result = NULL;
+
+ gdb_assert (c_smob != NULL);
+ gdb_assert (gdbscm_is_procedure (c_smob->complete));
+
+ text_scm = gdbscm_scm_from_string (text, strlen (text), host_charset (),
+ 1);
+ if (gdbscm_is_exception (text_scm))
+ error (_("Could not convert \"text\" argument to Scheme string."));
+ word_scm = gdbscm_scm_from_string (word, strlen (word), host_charset (),
+ 1);
+ if (gdbscm_is_exception (word_scm))
+ error (_("Could not convert \"word\" argument to Scheme string."));
+
+ completer_result_scm
+ = gdbscm_safe_call_3 (c_smob->complete, c_smob->containing_scm,
+ text_scm, word_scm, NULL);
+
+ if (gdbscm_is_exception (completer_result_scm))
+ {
+ /* Inform the user, but otherwise ignore. */
+ gdbscm_print_gdb_exception (SCM_BOOL_F, completer_result_scm);
+ goto done;
+ }
+
+ if (gdbscm_is_true (scm_list_p (completer_result_scm)))
+ {
+ SCM list = completer_result_scm;
+
+ while (!scm_is_eq (list, SCM_EOL))
+ {
+ SCM next = scm_car (list);
+
+ if (!cmdscm_add_completion (next, &result))
+ {
+ VEC_free (char_ptr, result);
+ goto done;
+ }
+
+ list = scm_cdr (list);
+ }
+ }
+ else if (itscm_is_iterator (completer_result_scm))
+ {
+ SCM iter = completer_result_scm;
+ SCM next = itscm_safe_call_next_x (iter, NULL);
+
+ while (gdbscm_is_true (next))
+ {
+ if (gdbscm_is_exception (next))
+ {
+ /* Inform the user, but otherwise ignore the entire result. */
+ gdbscm_print_gdb_exception (SCM_BOOL_F, completer_result_scm);
+ VEC_free (char_ptr, result);
+ goto done;
+ }
+
+ if (!cmdscm_add_completion (next, &result))
+ {
+ VEC_free (char_ptr, result);
+ goto done;
+ }
+
+ next = itscm_safe_call_next_x (iter, NULL);
+ }
+ }
+ else
+ {
+ /* Inform the user, but otherwise ignore. */
+ cmdscm_bad_completion_result (_("Bad completer result: "),
+ completer_result_scm);
+ }
+
+ done:
+ return result;
+}
+
+/* Helper for gdbscm_make_command_x which locates the command list to use and
+ pulls out the command name.
+
+ NAME is the command name list. The final word in the list is the
+ name of the new command. All earlier words must be existing prefix
+ commands.
+ NAME_SCM is the Scheme form of NAME and is used in error messages.
+
+ *BASE_LIST is set to the final prefix command's list of
+ *sub-commands.
+
+ START_LIST is the list in which the search starts.
+
+ This function returns the xmalloc()d name of the new command.
+ On error a Scheme exception is thrown. */
+
+char *
+gdbscm_parse_command_name (const char *name, SCM name_scm,
+ const char *func_name, int arg_pos,
+ struct cmd_list_element ***base_list,
+ struct cmd_list_element **start_list)
+{
+ struct cmd_list_element *elt;
+ int len = strlen (name);
+ int i, lastchar;
+ char *prefix_text;
+ const char *prefix_text2;
+ char *result, *msg;
+
+ /* Skip trailing whitespace. */
+ for (i = len - 1; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i)
+ ;
+ if (i < 0)
+ {
+ gdbscm_out_of_range_error (func_name, arg_pos, name_scm,
+ _("no command name found"));
+ }
+ lastchar = i;
+
+ /* Find first character of the final word. */
+ for (; i > 0 && (isalnum (name[i - 1])
+ || name[i - 1] == '-'
+ || name[i - 1] == '_');
+ --i)
+ ;
+ result = xmalloc (lastchar - i + 2);
+ memcpy (result, &name[i], lastchar - i + 1);
+ result[lastchar - i + 1] = '\0';
+
+ /* Skip whitespace again. */
+ for (--i; i >= 0 && (name[i] == ' ' || name[i] == '\t'); --i)
+ ;
+ if (i < 0)
+ {
+ *base_list = start_list;
+ return result;
+ }
+
+ prefix_text = xmalloc (i + 2);
+ memcpy (prefix_text, name, i + 1);
+ prefix_text[i + 1] = '\0';
+
+ prefix_text2 = prefix_text;
+ elt = lookup_cmd_1 (&prefix_text2, *start_list, NULL, 1);
+ if (!elt || elt == (struct cmd_list_element *) -1)
+ {
+ msg = xstrprintf (_("could not find command prefix '%s'"), prefix_text);
+ xfree (prefix_text);
+ xfree (result);
+ scm_dynwind_begin (0);
+ gdbscm_dynwind_xfree (msg);
+ gdbscm_out_of_range_error (func_name, arg_pos, name_scm, msg);
+ }
+
+ if (elt->prefixlist)
+ {
+ xfree (prefix_text);
+ *base_list = elt->prefixlist;
+ return result;
+ }
+
+ msg = xstrprintf (_("'%s' is not a prefix command"), prefix_text);
+ xfree (prefix_text);
+ xfree (result);
+ scm_dynwind_begin (0);
+ gdbscm_dynwind_xfree (msg);
+ gdbscm_out_of_range_error (func_name, arg_pos, name_scm, msg);
+ /* NOTREACHED */
+}
+
+static const scheme_integer_constant command_classes[] =
+{
+ /* Note: alias and user are special; pseudo appears to be unused,
+ and there is no reason to expose tui or xdb, I think. */
+ { "COMMAND_NONE", no_class },
+ { "COMMAND_RUNNING", class_run },
+ { "COMMAND_DATA", class_vars },
+ { "COMMAND_STACK", class_stack },
+ { "COMMAND_FILES", class_files },
+ { "COMMAND_SUPPORT", class_support },
+ { "COMMAND_STATUS", class_info },
+ { "COMMAND_BREAKPOINTS", class_breakpoint },
+ { "COMMAND_TRACEPOINTS", class_trace },
+ { "COMMAND_OBSCURE", class_obscure },
+ { "COMMAND_MAINTENANCE", class_maintenance },
+ { "COMMAND_USER", class_user },
+
+ END_INTEGER_CONSTANTS
+};
+
+/* Return non-zero if command_class is a valid command class. */
+
+int
+gdbscm_valid_command_class_p (int command_class)
+{
+ int i;
+
+ for (i = 0; command_classes[i].name != NULL; ++i)
+ {
+ if (command_classes[i].value == command_class)
+ return 1;
+ }
+
+ return 0;
+}
+
+/* (make-command! name [#:invoke lambda]
+ [#:command-class class] [#:completer-class completer]
+ [#:prefix? <bool>] [#:doc <string>]) -> <gdb:command>
+
+ NAME is the name of the command. It may consist of multiple words,
+ in which case the final word is the name of the new command, and
+ earlier words must be prefix commands.
+
+ INVOKE is a procedure of three arguments that performs the command when
+ invoked: (lambda (self arg from-tty) ...).
+ Its result is unspecified.
+
+ CLASS is the kind of command. It must be one of the COMMAND_*
+ constants defined in the gdb module. If not specified, "no_class" is used.
+
+ COMPLETER is the kind of completer. It must be either:
+ #f - completion is not supported for this command.
+ One of the COMPLETE_* constants defined in the gdb module.
+ A procedure of three arguments: (lambda (self text word) ...).
+ Its result is one of:
+ A list of strings.
+ A <gdb:iterator> object that returns the set of possible completions,
+ ending with #f.
+ TODO(dje): Once PR 16699 is fixed, add support for returning
+ a COMPLETE_* constant.
+ If not specified, then completion is not supported for this command.
+
+ If PREFIX is #t, then this command is a prefix command.
+
+ DOC is the doc string for the command. */
+
+static SCM
+gdbscm_make_command_x (SCM name_scm, SCM rest)
+{
+ const SCM keywords[] = {
+ invoke_keyword, command_class_keyword, completer_class_keyword,
+ prefix_p_keyword, doc_keyword, SCM_BOOL_F
+ };
+ int invoke_arg_pos = -1, command_class_arg_pos = 1;
+ int completer_class_arg_pos = -1, is_prefix_arg_pos = -1;
+ int doc_string_arg_pos = -1;
+ char *name;
+ int command_class = no_class;
+ SCM completer_class = SCM_BOOL_F;
+ int is_prefix = 0;
+ char *doc_string = NULL;
+ SCM invoke = SCM_BOOL_F;
+ SCM c_scm;
+ char *cmd_name, *pfx_name;
+ struct cmd_list_element **cmd_list;
+ command_smob *c_smob;
+ struct cmd_list_element *cmd = NULL;
+ volatile struct gdb_exception except;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#OiOts",
+ name_scm, &name, rest,
+ &invoke_arg_pos, &invoke,
+ &command_class_arg_pos, &command_class,
+ &completer_class_arg_pos, &completer_class,
+ &is_prefix_arg_pos, &is_prefix,
+ &doc_string_arg_pos, &doc_string);
+
+ scm_dynwind_begin (0);
+ gdbscm_dynwind_xfree (name);
+ gdbscm_dynwind_xfree (doc_string);
+
+ if (gdbscm_is_true (invoke))
+ {
+ SCM_ASSERT_TYPE (gdbscm_is_procedure (invoke), invoke,
+ invoke_arg_pos, FUNC_NAME, _("procedure"));
+ }
+
+ if (!gdbscm_valid_command_class_p (command_class))
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, command_class_arg_pos,
+ scm_from_int (command_class),
+ _("invalid command class argument"));
+ }
+
+ SCM_ASSERT_TYPE (gdbscm_is_false (completer_class)
+ || scm_is_integer (completer_class)
+ || gdbscm_is_procedure (completer_class),
+ completer_class, completer_class_arg_pos, FUNC_NAME,
+ _("integer or procedure"));
+ if (scm_is_integer (completer_class)
+ && !scm_is_signed_integer (completer_class, 0, N_COMPLETERS - 1))
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, completer_class_arg_pos,
+ completer_class,
+ _("invalid completion type argument"));
+ }
+
+ cmd_name = gdbscm_parse_command_name (name, name_scm, FUNC_NAME, SCM_ARG1,
+ &cmd_list, &cmdlist);
+ gdbscm_dynwind_xfree (cmd_name);
+
+ pfx_name = NULL;
+ if (is_prefix)
+ {
+ int i, out;
+
+ /* Make a normalized form of the command name. */
+ pfx_name = xmalloc (strlen (name) + 2);
+
+ i = 0;
+ out = 0;
+ while (name[i])
+ {
+ /* Skip whitespace. */
+ while (name[i] == ' ' || name[i] == '\t')
+ ++i;
+ /* Copy non-whitespace characters. */
+ while (name[i] && name[i] != ' ' && name[i] != '\t')
+ pfx_name[out++] = name[i++];
+ /* Add a single space after each word -- including the final
+ word. */
+ pfx_name[out++] = ' ';
+ }
+ pfx_name[out] = '\0';
+ }
+ gdbscm_dynwind_xfree (pfx_name);
+
+ c_scm = cmdscm_make_command_smob ();
+ c_smob = (command_smob *) SCM_SMOB_DATA (c_scm);
+
+ /* End of dynwind-protect region.
+ Alas there's no way to undo the dynwind protects we did.
+ To cope make a second copy of the objects we queued up for xfree.
+ No more Scheme exceptions are allowed after this point, except ones
+ we explicitly throw (so we can first clean up). */
+ name = xstrdup (name);
+ if (doc_string != NULL)
+ doc_string = xstrdup (doc_string);
+ cmd_name = xstrdup (cmd_name);
+ if (pfx_name != NULL)
+ pfx_name = xstrdup (pfx_name);
+ scm_dynwind_end ();
+
+ if (doc_string == NULL)
+ doc_string = xstrdup (_("This command is not documented."));
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (pfx_name)
+ {
+ /* If we have our own "invoke" method, then allow unknown
+ sub-commands. */
+ int allow_unknown = gdbscm_is_true (invoke);
+
+ cmd = add_prefix_cmd (cmd_name, (enum command_class) command_class,
+ NULL, doc_string, &c_smob->sub_list,
+ pfx_name, allow_unknown, cmd_list);
+ }
+ else
+ cmd = add_cmd (cmd_name, (enum command_class) command_class, NULL,
+ doc_string, cmd_list);
+ }
+ if (except.reason < 0)
+ {
+ xfree (cmd_name);
+ xfree (doc_string);
+ xfree (pfx_name);
+ gdbscm_throw_gdb_exception (except);
+ }
+
+ /* There appears to be no API to set this. */
+ cmd->func = cmdscm_function;
+ cmd->destroyer = cmdscm_destroyer;
+
+ c_smob->command = cmd;
+ c_smob->invoke = invoke;
+ c_smob->complete = completer_class;
+ set_cmd_context (cmd, c_smob);
+ if (gdbscm_is_true (completer_class))
+ {
+ set_cmd_completer (cmd,
+ scm_is_integer (completer_class)
+ ? cmdscm_completers[scm_to_int (completer_class)].completer
+ : cmdscm_completer);
+ }
+
+ /* The owner of this command is not in GC-controlled memory, so we need
+ to protect it from GC until the command is deleted. */
+ scm_gc_protect_object (c_scm);
+
+ return c_scm;
+}
+
+/* Initialize the Scheme command support. */
+
+static const scheme_function command_functions[] =
+{
+ { "make-command!", 1, 0, 1, gdbscm_make_command_x,
+ "\
+Make a GDB command object.\n\
+\n\
+ Arguments: name [#:invoke lambda]\n\
+ [#:command-class <class>] [#:completer-class <completer>]\n\
+ [#:prefix? <bool>] [#:doc string]\n\
+ name: The name of the command. It may consist of multiple words,\n\
+ in which case the final word is the name of the new command, and\n\
+ earlier words must be prefix commands.\n\
+ invoke: A procedure of three arguments to perform the command.\n\
+ (lambda (self arg from-tty) ...)\n\
+ Its result is unspecified.\n\
+ class: The class of the command, one of COMMAND_*.\n\
+ The default is COMMAND_NONE.\n\
+ completer: The kind of completer, #f, one of COMPLETE_*, or a procedure\n\
+ to perform the completion: (lambda (self text word) ...).\n\
+ prefix?: If true then the command is a prefix command.\n\
+ doc: The \"doc string\" of the command.\n\
+ Returns: <gdb:command> object" },
+
+ { "command?", 1, 0, 0, gdbscm_command_p,
+ "\
+Return #t if the object is a <gdb:command> object." },
+
+ { "command-valid?", 1, 0, 0, gdbscm_command_valid_p,
+ "\
+Return #t if the <gdb:command> object is valid." },
+
+ { "dont-repeat", 1, 0, 0, gdbscm_dont_repeat,
+ "\
+Prevent command repetition when user enters an empty line.\n\
+\n\
+ Arguments: <gdb:command>\n\
+ Returns: unspecified" },
+
+ END_FUNCTIONS
+};
+
+/* Initialize the 'commands' code. */
+
+void
+gdbscm_initialize_commands (void)
+{
+ int i;
+
+ command_smob_tag
+ = gdbscm_make_smob_type (command_smob_name, sizeof (command_smob));
+ scm_set_smob_print (command_smob_tag, cmdscm_print_command_smob);
+
+ gdbscm_define_integer_constants (command_classes, 1);
+ gdbscm_define_functions (command_functions, 1);
+
+ for (i = 0; i < N_COMPLETERS; ++i)
+ {
+ scm_c_define (cmdscm_completers[i].name, scm_from_int (i));
+ scm_c_export (cmdscm_completers[i].name, NULL);
+ }
+
+ invoke_keyword = scm_from_latin1_keyword ("invoke");
+ command_class_keyword = scm_from_latin1_keyword ("command-class");
+ completer_class_keyword = scm_from_latin1_keyword ("completer-class");
+ prefix_p_keyword = scm_from_latin1_keyword ("prefix?");
+ doc_keyword = scm_from_latin1_keyword ("doc");
+}
diff --git a/gdb/guile/scm-exception.c b/gdb/guile/scm-exception.c
index a96a350..121ecb4 100644
--- a/gdb/guile/scm-exception.c
+++ b/gdb/guile/scm-exception.c
@@ -64,6 +64,9 @@ static SCM memory_error_symbol;
/* User interrupt, e.g., RETURN_QUIT in struct gdb_exception. */
static SCM signal_symbol;
+/* A user error, e.g., bad arg to gdb command. */
+static SCM user_error_symbol;
+
/* Printing the stack is done by first capturing the stack and recording it in
a <gdb:exception> object with this key and with the ARGS field set to
(cons real-key (cons stack real-args)).
@@ -404,6 +407,15 @@ gdbscm_memory_error_p (SCM key)
return scm_is_eq (key, memory_error_symbol);
}
+/* Return non-zero if KEY is gdb:user-error.
+ Note: This is an excp_matcher_func function. */
+
+int
+gdbscm_user_error_p (SCM key)
+{
+ return scm_is_eq (key, user_error_symbol);
+}
+
/* Wrapper around scm_throw to throw a gdb:exception.
This function does not return.
This function cannot be called from inside TRY_CATCH. */
@@ -677,6 +689,8 @@ gdbscm_initialize_exceptions (void)
memory_error_symbol = scm_from_latin1_symbol ("gdb:memory-error");
+ user_error_symbol = scm_from_latin1_symbol ("gdb:user-error");
+
gdbscm_invalid_object_error_symbol
= scm_from_latin1_symbol ("gdb:invalid-object-error");
diff --git a/gdb/testsuite/gdb.guile/scm-cmd.c b/gdb/testsuite/gdb.guile/scm-cmd.c
new file mode 100644
index 0000000..7f0dc59
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-cmd.c
@@ -0,0 +1,29 @@
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2013 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/>. */
+
+struct foo
+{
+ int ij;
+ int bc;
+};
+
+int
+main (void)
+{
+ struct foo bar;
+ return 0;
+}
diff --git a/gdb/testsuite/gdb.guile/scm-cmd.exp b/gdb/testsuite/gdb.guile/scm-cmd.exp
new file mode 100644
index 0000000..b3d94b1
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/scm-cmd.exp
@@ -0,0 +1,206 @@
+# Copyright (C) 2009-2013 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/>.
+
+# This file is part of the GDB testsuite. It tests the mechanism
+# for defining new GDB commands in Scheme.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
+ return
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+if ![gdb_guile_runto_main] {
+ fail "Can't run to main"
+ return
+}
+
+# Test a simple command, and command? while we're at it.
+
+gdb_test_multiline "input simple command" \
+ "guile" "" \
+ "(define test-cmd" "" \
+ " (make-command! \"test-cmd\"" "" \
+ " #:command-class COMMAND_OBSCURE" "" \
+ " #:invoke (lambda (self arg from-tty)" "" \
+ " (display (format #f \"test-cmd output, arg = ~a\\n\" arg)))))" "" \
+ "end" ""
+
+gdb_test "guile (print (command? test-cmd))" "= #t"
+gdb_test "guile (print (command? 42))" "= #f"
+
+gdb_test "test-cmd ugh" "test-cmd output, arg = ugh" "call simple command"
+
+# Test a prefix command, and a subcommand within it.
+
+gdb_test_multiline "input prefix command" \
+ "guile" "" \
+ "(make-command! \"prefix-cmd\"" "" \
+ " #:command-class COMMAND_OBSCURE" "" \
+ " #:completer-class COMPLETE_NONE" "" \
+ " #:prefix? #t" "" \
+ " #:invoke (lambda (self arg from-tty)" "" \
+ " (display (format #f \"prefix-cmd output, arg = ~a\\n\" arg))))" "" \
+ "end" ""
+
+gdb_test "prefix-cmd ugh" "prefix-cmd output, arg = ugh" "call prefix command"
+
+gdb_test_multiline "input subcommand" \
+ "guile" "" \
+ "(make-command! \"prefix-cmd subcmd\"" "" \
+ " #:command-class COMMAND_OBSCURE" "" \
+ " #:invoke (lambda (self arg from-tty)" "" \
+ " (display (format #f \"subcmd output, arg = ~a\\n\" arg))))" "" \
+ "end" ""
+
+gdb_test "prefix-cmd subcmd ugh" "subcmd output, arg = ugh" "call subcmd"
+
+# Test a subcommand in an existing GDB prefix.
+
+gdb_test_multiline "input new subcommand" \
+ "guile" "" \
+ "(make-command! \"info newsubcmd\"" "" \
+ " #:command-class COMMAND_OBSCURE" "" \
+ " #:invoke (lambda (self arg from-tty)" "" \
+ " (display (format #f \"newsubcmd output, arg = ~a\\n\" arg))))" "" \
+ "end" ""
+
+gdb_test "info newsubcmd ugh" "newsubcmd output, arg = ugh" "call newsubcmd"
+
+# Test a command that throws gdb:user-error.
+
+gdb_test_multiline "input command to throw error" \
+ "guile" "" \
+ "(make-command! \"test-error-cmd\"" "" \
+ " #:command-class COMMAND_OBSCURE" "" \
+ " #:invoke (lambda (self arg from-tty)" "" \
+ " (throw-user-error \"you lose!\")))" "" \
+ "end" ""
+
+gdb_test "test-error-cmd ugh" "you lose!" "call error command"
+
+# Test string->argv.
+
+gdb_test "guile (raw-print (string->argv \"1 2 3\"))" \
+ {= \("1" "2" "3"\)} \
+ "(string->argv \"1 2 3\")"
+
+gdb_test "guile (raw-print (string->argv \"'1 2' 3\"))" \
+ {= \("1 2" "3"\)} \
+ "(string->argv \"'1 2' 3\")"
+
+gdb_test "guile (raw-print (string->argv \"\\\"1 2\\\" 3\"))" \
+ {= \("1 2" "3"\)} \
+ "(string->argv (\"\\\"1 2\\\" 3\")"
+
+gdb_test "guile (raw-print (string->argv \"1\\\\ 2 3\"))" \
+ {= \("1 2" "3"\)} \
+ "(string->argv \"1\\\\ 2 3\")"
+
+# Test user-defined guile commands.
+
+gdb_test_multiline "input simple user-defined command" \
+ "guile" "" \
+ "(make-command! \"test-help\"" "" \
+ " #:doc \"Docstring\"" "" \
+ " #:command-class COMMAND_USER" "" \
+ " #:invoke (lambda (self arg from-tty)" "" \
+ " (display (format #f \"test-cmd output, arg = ~a\\n\" arg))))" "" \
+ "end" ""
+
+gdb_test "test-help ugh" "test-cmd output, arg = ugh" \
+ "call simple user-defined command"
+
+# Make sure the command shows up in `help user-defined`.
+gdb_test "help user-defined" \
+ "User-defined commands.\[\r\n\]+The commands in this class are those defined by the user.\[\r\n\]+Use the \"define\" command to define a command.\[\r\n\]+List of commands:\[\r\n\]+test-help -- Docstring\[\r\n\]+Type \"help\" followed by command name for full documentation.\[\r\n\]+Type \"apropos word\" to search for commands related to \"word\".\[\r\n\]+Command name abbreviations are allowed if unambiguous.\[\r\n\]+" \
+ "see user-defined command in `help user-defined`"
+
+# Test expression completion on fields.
+
+gdb_test_multiline "expression completion command" \
+ "guile" "" \
+ "(make-command! \"expr-test\"" "" \
+ " #:command-class COMMAND_USER" ""\
+ " #:completer-class COMPLETE_EXPRESSION" "" \
+ " #:invoke (lambda (self arg from-tty)" "" \
+ " (display (format #f \"invoked on = ~a\\n\" arg))))" "" \
+ "end" ""
+
+gdb_test "complete expr-test bar\." \
+ "expr-test bar\.bc.*expr-test bar\.ij.*" \
+ "test completion through complete command"
+
+set test "complete 'expr-test bar.i'"
+send_gdb "expr-test bar\.i\t\t"
+gdb_test_multiple "" "$test" {
+ -re "expr-test bar\.ij \\\x07$" {
+ send_gdb "\n"
+ gdb_test_multiple "" $test {
+ -re "invoked on = bar.ij.*$gdb_prompt $" {
+ pass "$test"
+ }
+ }
+ }
+}
+
+# Test using a function for completion.
+
+gdb_test_multiline "completer-as-function command" \
+ "guile" "" \
+ "(make-command! \"completer-as-function\"" "" \
+ " #:command-class COMMAND_USER" ""\
+ " #:completer-class (lambda (self text word)" "" \
+ " (list \"1\" \"2\" \"3\"))" "" \
+ " #:invoke (lambda (self arg from-tty)" "" \
+ " (display (format #f \"invoked on = ~a\\n\" arg))))" "" \
+ "end" ""
+
+gdb_test "complete completer-as-function 42\." \
+ "completer-as-function 42\.1.*completer-as-function 42\.2.*completer-as-function 42\.3" \
+ "test completion with completion function"
+
+# Test Scheme error in invoke function.
+
+gdb_test_multiline "input command with Scheme error" \
+ "guile" "" \
+ "(make-command! \"test-scheme-error-cmd\"" "" \
+ " #:command-class COMMAND_OBSCURE" "" \
+ " #:invoke (lambda (self arg from-tty)" "" \
+ " oops-bad-spelling))" "" \
+ "end" ""
+
+gdb_test "test-scheme-error-cmd ugh" \
+ "Error occurred in Scheme-implemented GDB command." \
+ "call scheme-error command"
+
+# Test throw-user-error.
+
+gdb_test_multiline "command calling throw-user-error" \
+ "guile" "" \
+ "(make-command! \"test-user-error\"" "" \
+ " #:command-class COMMAND_OBSCURE" "" \
+ " #:invoke (lambda (self arg from-tty)" "" \
+ " (throw-user-error \"Bad argument ~a\" arg)))" "" \
+ "end" ""
+
+gdb_test "test-user-error ugh" \
+ "ERROR: Bad argument ugh" \
+ "call test-user-error command"