diff options
| -rw-r--r-- | gdb/ChangeLog | 22 | ||||
| -rw-r--r-- | gdb/Makefile.in | 6 | ||||
| -rw-r--r-- | gdb/doc/ChangeLog | 8 | ||||
| -rw-r--r-- | gdb/doc/guile.texi | 293 | ||||
| -rw-r--r-- | gdb/guile/guile-internal.h | 14 | ||||
| -rw-r--r-- | gdb/guile/guile.c | 1 | ||||
| -rw-r--r-- | gdb/guile/lib/gdb.scm | 29 | ||||
| -rw-r--r-- | gdb/guile/lib/gdb/init.scm | 10 | ||||
| -rw-r--r-- | gdb/guile/scm-cmd.c | 893 | ||||
| -rw-r--r-- | gdb/guile/scm-exception.c | 14 | ||||
| -rw-r--r-- | gdb/guile/scm-utils.c | 12 | ||||
| -rw-r--r-- | gdb/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.guile/scm-cmd.c | 29 | ||||
| -rw-r--r-- | gdb/testsuite/gdb.guile/scm-cmd.exp | 198 |
14 files changed, 1527 insertions, 7 deletions
diff --git a/gdb/ChangeLog b/gdb/ChangeLog index 414ac6d..ff829fc 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,3 +1,25 @@ +2014-06-02 Doug Evans <xdje42@gmail.com> + + Add command support for Guile. + * 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_gc_xstrdup): Declare. + (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. + * scm-utils.c (gdbscm_gc_xstrdup): New function. + 2014-06-02 Phil Muldoon <pmuldoon@redhat.com> * top.c (command_loop): Handle comments here... diff --git a/gdb/Makefile.in b/gdb/Makefile.in index 51aeeb3..6159918 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 \ @@ -312,6 +313,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 \ @@ -2272,6 +2274,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/ChangeLog b/gdb/doc/ChangeLog index cbe00db..f2dafe3 100644 --- a/gdb/doc/ChangeLog +++ b/gdb/doc/ChangeLog @@ -1,5 +1,13 @@ 2014-06-02 Doug Evans <xdje42@gmail.com> + * 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. + +2014-06-02 Doug Evans <xdje42@gmail.com> + * guile.texi (Guile API): Add entry for Progspaces In Guile. (GDB Scheme Data Types): Mention <gdb:progspace> object. (Progspaces In Guile): New node. diff --git a/gdb/doc/guile.texi b/gdb/doc/guile.texi index 23c8398..70fbd16 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 * Progspaces In Guile:: Program spaces * Objfiles In Guile:: Object files in Guile * Frames In Guile:: Accessing inferior stack frames from Guile @@ -293,16 +294,14 @@ Parse @var{expression} as an expression in the current language, evaluate it, and return the result as a @code{<gdb:value>}. The @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 arguments 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 @@ -358,6 +357,9 @@ as a symbol. @item <gdb:breakpoint> @xref{Breakpoints In Guile}. +@item <gdb:command> +@xref{Commands In Guile}. + @item <gdb:exception> @xref{Guile Exception Handling}. @@ -1665,6 +1667,285 @@ 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 object is created with the @code{make-command} Guile function, +and added to @value{GDBN} with the @code{register-command!} Guile function. +This two-step approach is taken to separate out the side-effect of adding +the command to @value{GDBN} from @code{make-command}. + +There is no support for multi-line commands, that is commands that +consist of multiple lines and are terminated with @code{end}. + +@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{]}) + +The argument @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 command is not usable until it has been registered with @value{GDBN} +with @code{register-command!}. + +The rest of the arguments are optional. + +The argument @var{invoke} is a procedure of three arguments: @var{self}, +@var{args} and @var{from-tty}. The argument @var{self} is the +@code{<gdb:command>} object representing the command. +The argument @var{args} is a string representing the arguments passed to +the command, after leading and trailing whitespace has been stripped. +The argument @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. + +The argument @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}. + +The argument @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. + +The argument @var{prefix} is a boolean flag indicating whether the new +command is a prefix command; sub-commands of this command may be +registered. + +The argument @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 + +@deffn {Scheme Procedure} register-command! command +Add @var{command}, a @code{<gdb:command>} object, to @value{GDBN}'s +list of commands. +It is an error to register a command more than once. +The result is unspecified. +@end deffn + +@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. +The argument @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}. +The argument @var{args} is a list of 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 +(register-command! (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. +The argument @var{text} holds the complete command line up to the cursor's +location. The argument @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 @code{<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 will have been 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. +This is the default. + +@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 +(register-command! (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 Progspaces In Guile @subsubsection Program Spaces In Guile diff --git a/gdb/guile/guile-internal.h b/gdb/guile/guile-internal.h index 9f6a886..042ece9 100644 --- a/gdb/guile/guile-internal.h +++ b/gdb/guile/guile-internal.h @@ -164,6 +164,8 @@ extern ULONGEST gdbscm_scm_to_ulongest (SCM u); extern void gdbscm_dynwind_xfree (void *ptr); extern int gdbscm_is_procedure (SCM proc); + +extern char *gdbscm_gc_xstrdup (const char *); /* GDB smobs, from scm-gsmob.c */ @@ -315,6 +317,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); @@ -375,6 +379,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, + 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; @@ -543,6 +556,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 51919de..c4e5832 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 646ca81..a3f43a4 100644 --- a/gdb/guile/lib/gdb.scm +++ b/gdb/guile/lib/gdb.scm @@ -141,6 +141,34 @@ set-breakpoint-stop! breakpoint-commands + ;; scm-cmd.c + + make-command + register-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 @@ -457,4 +485,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..1e90790 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,10 @@ (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" are a bit obscure, +;; so give the user something simpler. + +(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..ee3674c --- /dev/null +++ b/gdb/guile/scm-cmd.c @@ -0,0 +1,893 @@ +/* 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. + + Note: Commands are added to gdb using a two step process: + 1) Call make-command to create a <gdb:command> object. + 2) Call register-command! to add the command to gdb. + It is done this way so that the constructor, make-command, doesn't have + any side-effects. This means that the smob needs to store everything + that was passed to make-command. */ + +typedef struct _command_smob +{ + /* This always appears first. */ + gdb_smob base; + + /* The name of the command, as passed to make-command. */ + char *name; + + /* The last word of the command. + This is needed because add_cmd requires us to allocate space + for it. :-( */ + char *cmd_name; + + /* Non-zero if this is a prefix command. */ + int is_prefix; + + /* One of the COMMAND_* constants. */ + enum command_class cmd_class; + + /* The documentation for the command. */ + char *doc; + + /* The corresponding gdb command object. + This is NULL if the command has not been registered yet, or + is no longer registered. */ + 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. + This is NULL if the command has not been registered yet, or + is no longer registered. 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])) + +static int cmdscm_is_valid (command_smob *); + +/* 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->name != NULL ? c_smob->name : "{unnamed}"); + + if (! cmdscm_is_valid (c_smob)) + scm_puts (" {invalid}", port); + + 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; + + memset (c_smob, 0, sizeof (*c_smob)); + c_smob->cmd_class = no_class; + 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 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. + + *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, + 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, + gdbscm_scm_from_c_string (name), + _("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, + gdbscm_scm_from_c_string (name), 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, + gdbscm_scm_from_c_string (name), 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; +} + +/* Return a normalized form of command NAME. + That is tabs are replaced with spaces and multiple spaces are replaced + with a single space. + If WANT_TRAILING_SPACE is non-zero, add one space at the end. This is for + prefix commands. + but that is the caller's responsibility. + Space for the result is allocated on the GC heap. */ + +static char * +cmdscm_canonicalize_name (const char *name, int want_trailing_space) +{ + int i, out, seen_word; + char *result = scm_gc_malloc_pointerless (strlen (name) + 2, FUNC_NAME); + + i = out = seen_word = 0; + while (name[i]) + { + /* Skip whitespace. */ + while (name[i] == ' ' || name[i] == '\t') + ++i; + /* Copy non-whitespace characters. */ + if (name[i]) + { + if (seen_word) + result[out++] = ' '; + while (name[i] && name[i] != ' ' && name[i] != '\t') + result[out++] = name[i++]; + seen_word = 1; + } + } + if (want_trailing_space) + result[out++] = ' '; + result[out] = '\0'; + + return result; +} + +/* (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. + + The result is the <gdb:command> Scheme object. + The command is not available to be used yet, however. + It must still be added to gdb with register-command!. */ + +static SCM +gdbscm_make_command (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_arg_pos = -1; + char *s; + char *name; + int command_class = no_class; + SCM completer_class = SCM_BOOL_F; + int is_prefix = 0; + char *doc = NULL; + SCM invoke = SCM_BOOL_F; + SCM c_scm; + command_smob *c_smob; + + 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_arg_pos, &doc); + + if (doc == NULL) + doc = xstrdup (_("This command is not documented.")); + + s = name; + name = cmdscm_canonicalize_name (s, is_prefix); + xfree (s); + s = doc; + doc = gdbscm_gc_xstrdup (s); + xfree (s); + + if (is_prefix + ? name[0] == ' ' + : name[0] == '\0') + { + gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, name_scm, + _("no command name found")); + } + + 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")); + } + + c_scm = cmdscm_make_command_smob (); + c_smob = (command_smob *) SCM_SMOB_DATA (c_scm); + c_smob->name = name; + c_smob->is_prefix = is_prefix; + c_smob->cmd_class = command_class; + c_smob->doc = doc; + c_smob->invoke = invoke; + c_smob->complete = completer_class; + + return c_scm; +} + +/* (register-command! <gdb:command>) -> unspecified + + It is an error to register a command more than once. */ + +static SCM +gdbscm_register_command_x (SCM self) +{ + command_smob *c_smob + = cmdscm_get_command_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME); + char *cmd_name, *pfx_name; + struct cmd_list_element **cmd_list; + struct cmd_list_element *cmd = NULL; + volatile struct gdb_exception except; + + if (cmdscm_is_valid (c_smob)) + scm_misc_error (FUNC_NAME, _("command is already registered"), SCM_EOL); + + cmd_name = gdbscm_parse_command_name (c_smob->name, FUNC_NAME, SCM_ARG1, + &cmd_list, &cmdlist); + c_smob->cmd_name = gdbscm_gc_xstrdup (cmd_name); + xfree (cmd_name); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + if (c_smob->is_prefix) + { + /* If we have our own "invoke" method, then allow unknown + sub-commands. */ + int allow_unknown = gdbscm_is_true (c_smob->invoke); + + cmd = add_prefix_cmd (c_smob->cmd_name, c_smob->cmd_class, + NULL, c_smob->doc, &c_smob->sub_list, + c_smob->name, allow_unknown, cmd_list); + } + else + { + cmd = add_cmd (c_smob->cmd_name, c_smob->cmd_class, + NULL, c_smob->doc, cmd_list); + } + } + GDBSCM_HANDLE_GDB_EXCEPTION (except); + + /* Note: At this point the command exists in gdb. + So no more errors after this point. */ + + /* There appears to be no API to set this. */ + cmd->func = cmdscm_function; + cmd->destroyer = cmdscm_destroyer; + + c_smob->command = cmd; + set_cmd_context (cmd, c_smob); + + if (gdbscm_is_true (c_smob->complete)) + { + set_cmd_completer (cmd, + scm_is_integer (c_smob->complete) + ? cmdscm_completers[scm_to_int (c_smob->complete)].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_smob->containing_scm); + + return SCM_UNSPECIFIED; +} + +/* Initialize the Scheme command support. */ + +static const scheme_function command_functions[] = +{ + { "make-command", 1, 0, 1, gdbscm_make_command, + "\ +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" }, + + { "register-command!", 1, 0, 0, gdbscm_register_command_x, + "\ +Register a <gdb:command> object with GDB." }, + + { "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 f773a7d..0f3c875 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)). @@ -391,6 +394,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. */ @@ -663,6 +675,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/guile/scm-utils.c b/gdb/guile/scm-utils.c index 9e9901d..918a51b 100644 --- a/gdb/guile/scm-utils.c +++ b/gdb/guile/scm-utils.c @@ -583,3 +583,15 @@ gdbscm_is_procedure (SCM proc) { return gdbscm_is_true (scm_procedure_p (proc)); } + +/* Same as xstrdup, but the string is allocated on the GC heap. */ + +char * +gdbscm_gc_xstrdup (const char *str) +{ + size_t len = strlen (str); + char *result = scm_gc_malloc_pointerless (len + 1, "gdbscm_gc_xstrdup"); + + strcpy (result, str); + return result; +} diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog index 718ce24..bec3ce4 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,5 +1,10 @@ 2014-06-02 Doug Evans <xdje42@gmail.com> + * gdb.guile/scm-cmd.c: New file. + * gdb.guile/scm-cmd.exp: New file. + +2014-06-02 Doug Evans <xdje42@gmail.com> + * gdb.guile/scm-pretty-print.exp: Add tests for objfile and progspace pretty-printer lookup. * gdb.guile/scm-pretty-print.scm (pp_s-printer): New function. 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..a407f63 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-cmd.exp @@ -0,0 +1,198 @@ +# 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)))))" "" \ + "(register-command! test-cmd)" "" \ + "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" "" \ + "(register-command! (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" "" \ + "(register-command! (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" "" \ + "(register-command! (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" "" \ + "(register-command! (make-command \"test-error-cmd\"" "" \ + " #:command-class COMMAND_OBSCURE" "" \ + " #:invoke (lambda (self arg from-tty)" "" \ + " (throw-user-error \"you lose! ~a\" arg))))" "" \ + "end" "" + +gdb_test "test-error-cmd ugh" "ERROR: you lose! ugh" "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" "" \ + "(register-command! (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" "" \ + "(register-command! (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" "" \ + "(register-command! (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" "" \ + "(register-command! (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" + +# If there is a problem with object management, this can often trigger it. +# It is useful to do this last, after we've created a bunch of command objects. + +gdb_test_no_output "guile (gc)" |