This is the mail archive of the
gdb-patches@sourceware.org
mailing list for the GDB project.
[PATCH v1 10/36] Guile extension language: guile.c, guile.h
- From: Doug Evans <xdje42 at gmail dot com>
- To: gdb-patches at sourceware dot org
- Date: Tue, 24 Dec 2013 11:02:55 -0800
- Subject: [PATCH v1 10/36] Guile extension language: guile.c, guile.h
- Authentication-results: sourceware.org; auth=none
This patch adds guile.c, guile.h, guile-internal.h, akin to the
python versions.
2013-12-24 Doug Evans <xdje42@gmail.com>
* guile/guile-internal.h: New file.
* guile/guile.c: New file.
* guile/guile.h: New file.
testsuite/
* gdb.guile/guile.exp: New file.
* gdb.guile/source2.scm: New file.
diff --git a/gdb/guile/guile-internal.h b/gdb/guile/guile-internal.h
new file mode 100644
index 0000000..55c5ded
--- /dev/null
+++ b/gdb/guile/guile-internal.h
@@ -0,0 +1,585 @@
+/* Internal header for GDB/Scheme code.
+
+ Copyright (C) 2013 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. */
+
+#ifndef GDB_GUILE_INTERNAL_H
+#define GDB_GUILE_INTERNAL_H
+
+#include "hashtab.h"
+#include "extension-priv.h"
+#include "symtab.h"
+#include "libguile.h"
+
+struct block;
+struct frame_info;
+struct objfile;
+struct symbol;
+
+/* A function to pass to the safe-call routines to ignore things like
+ memory errors. */
+typedef int excp_matcher_func (SCM key);
+
+/* Scheme variables to define during initialization. */
+
+typedef struct
+{
+ const char *name;
+ SCM value;
+ const char *doc_string;
+} scheme_variable;
+
+/* End of scheme_variable table mark. */
+
+#define END_VARIABLES { NULL, SCM_BOOL_F, NULL }
+
+/* Scheme functions to define during initialization. */
+
+typedef struct
+{
+ const char *name;
+ int required;
+ int optional;
+ int rest;
+ scm_t_subr func;
+ const char *doc_string;
+} scheme_function;
+
+/* End of scheme_function table mark. */
+
+#define END_FUNCTIONS { NULL, 0, 0, 0, NULL, NULL }
+
+/* Useful for defining a set of constants. */
+
+typedef struct
+{
+ const char *name;
+ int value;
+} scheme_integer_constant;
+
+#define END_INTEGER_CONSTANTS { NULL, 0 }
+
+/* Pass this instead of 0 to routines like SCM_ASSERT to indicate the value
+ is not a function argument. */
+#define GDBSCM_ARG_NONE 0
+
+/* Ensure new code doesn't accidentally try to use this. */
+#undef scm_make_smob_type
+#define scm_make_smob_type USE_gdbscm_make_smob_type_INSTEAD
+
+/* They brought over () == #f from lisp.
+ Let's avoid that for now. */
+#undef scm_is_bool
+#undef scm_is_false
+#undef scm_is_true
+#define scm_is_bool USE_gdbscm_is_bool_INSTEAD
+#define scm_is_false USE_gdbscm_is_false_INSTEAD
+#define scm_is_true USE_gdbscm_is_true_INSTEAD
+#define gdbscm_is_bool(scm) \
+ (scm_is_eq ((scm), SCM_BOOL_F) || scm_is_eq ((scm), SCM_BOOL_T))
+#define gdbscm_is_false(scm) scm_is_eq ((scm), SCM_BOOL_F)
+#define gdbscm_is_true(scm) (!gdbscm_is_false (scm))
+
+/* Function name that is passed around in case an error needs to be reported.
+ __func is in C99, but we provide a wrapper "just in case",
+ and because FUNC_NAME is the canonical value used in guile sources.
+ IWBN to use the Scheme version of the name (e.g. foo-bar vs foo_bar),
+ but let's KISS for now. */
+#define FUNC_NAME __func__
+
+extern const char gdbscm_module_name[];
+extern const char gdbscm_init_module_name[];
+
+extern int gdb_scheme_initialized;
+
+extern const char gdbscm_print_excp_none[];
+extern const char gdbscm_print_excp_full[];
+extern const char gdbscm_print_excp_message[];
+extern const char *gdbscm_print_excp;
+
+extern SCM gdbscm_documentation_symbol;
+extern SCM gdbscm_invalid_object_error_symbol;
+
+extern SCM gdbscm_map_string;
+extern SCM gdbscm_array_string;
+extern SCM gdbscm_string_string;
+
+/* scm-utils.c */
+
+extern void gdbscm_define_variables (const scheme_variable *, int public);
+
+extern void gdbscm_define_functions (const scheme_function *, int public);
+
+extern void gdbscm_define_integer_constants (const scheme_integer_constant *,
+ int public);
+
+extern void gdbscm_printf (SCM port, const char *format, ...);
+
+extern void gdbscm_debug_display (SCM obj);
+
+extern void gdbscm_debug_write (SCM obj);
+
+extern void gdbscm_parse_function_args (const char *function_name,
+ int beginning_arg_pos,
+ const SCM *keywords,
+ const char *format, ...);
+
+extern SCM gdbscm_scm_from_longest (LONGEST l);
+
+extern LONGEST gdbscm_scm_to_longest (SCM l);
+
+extern SCM gdbscm_scm_from_ulongest (ULONGEST l);
+
+extern ULONGEST gdbscm_scm_to_ulongest (SCM u);
+
+extern SCM gdbscm_symbol_from_c_string (const char *symbol);
+
+extern void gdbscm_dynwind_xfree (void *ptr);
+
+extern int gdbscm_is_procedure (SCM proc);
+
+/* GDB smobs, from scm-smob.c */
+
+/* All gdb smobs must contain one of the following as the first member:
+ gdb_smob, chained_gdb_smob, or eqable_gdb_smob.
+
+ The next,prev members of chained_gdb_smob allow for chaining gsmobs
+ together so that, for example, when an objfile is deleted we can clean up
+ all smobs that reference it.
+
+ The containing_scm member of eqable_gdb_smob allows for returning the
+ same gsmob instead of creating a new one, allowing them to be eq?-able.
+
+ IMPORTANT: chained_gdb_smob and eqable_gdb-smob are a "subclasses" of
+ gdb_smob. The layout of chained_gdb_smob,eqable_gdb_smob must match
+ gdb_smob as if it is a subclass. To that end we use macro GDB_SMOB_HEAD
+ to ensure this. */
+
+#define GDB_SMOB_HEAD \
+ /* An auxiliary object for use by the user. */ \
+ SCM aux;
+
+typedef struct
+{
+ GDB_SMOB_HEAD
+} gdb_smob;
+
+typedef struct _chained_gdb_smob
+{
+ GDB_SMOB_HEAD
+
+ struct _chained_gdb_smob *prev;
+ struct _chained_gdb_smob *next;
+} chained_gdb_smob;
+
+typedef struct _eqable_gdb_smob
+{
+ GDB_SMOB_HEAD
+
+ /* The object we are contained in.
+ This can be used for several purposes.
+ This is used by the eq? machinery: We need to be able to see if we have
+ already created an object for a symbol, and if so use that SCM.
+ This may also be used to protect the smob from GC if there is
+ a reference to this smob from outside of GC space (i.e., from gdb).
+ This can also be used in place of chained_gdb_smob where we need to
+ keep track of objfile referencing objects. When the objfile is deleted
+ we need to invalidate the objects: we can do that using the same hashtab
+ used to record the smob for eq-ability. */
+ SCM containing_scm;
+} eqable_gdb_smob;
+
+#undef GDB_SMOB_HEAD
+
+struct objfile;
+struct objfile_data;
+
+/* A predicate that returns non-zero if an object is a particular kind
+ of gsmob. */
+typedef int (gsmob_pred_func) (SCM);
+
+extern scm_t_bits gdbscm_make_smob_type (const char *name, size_t size);
+
+extern void gdbscm_init_gsmob (gdb_smob *base);
+
+extern void gdbscm_init_chained_gsmob (chained_gdb_smob *base);
+
+extern void gdbscm_init_eqable_gsmob (eqable_gdb_smob *base);
+
+extern SCM gdbscm_mark_gsmob (gdb_smob *base);
+
+extern SCM gdbscm_mark_chained_gsmob (chained_gdb_smob *base);
+
+extern SCM gdbscm_mark_eqable_gsmob (eqable_gdb_smob *base);
+
+extern SCM gdbscm_scm_from_gsmob_safe (SCM smob);
+
+extern SCM gdbscm_scm_from_gsmob_unsafe (SCM smob);
+
+extern SCM gdbscm_scm_to_gsmob_safe (SCM scm, scm_t_bits tag);
+
+extern SCM gdbscm_scm_to_gsmob_unsafe (SCM scm, scm_t_bits tag);
+
+extern void gdbscm_add_objfile_ref (struct objfile *objfile,
+ const struct objfile_data *data_key,
+ chained_gdb_smob *g_smob);
+
+extern void gdbscm_remove_objfile_ref (struct objfile *objfile,
+ const struct objfile_data *data_key,
+ chained_gdb_smob *g_smob);
+
+extern htab_t gdbscm_create_eqable_gsmob_ptr_map (htab_hash hash_fn,
+ htab_eq eq_fn);
+
+extern eqable_gdb_smob **gdbscm_find_eqable_gsmob_ptr_slot
+ (htab_t htab, eqable_gdb_smob *base);
+
+extern void gdbscm_fill_eqable_gsmob_ptr_slot (eqable_gdb_smob **slot,
+ eqable_gdb_smob *base,
+ SCM containing_scm);
+
+extern void gdbscm_clear_eqable_gsmob_ptr_slot (htab_t htab,
+ eqable_gdb_smob *base);
+
+/* Exceptions and calling out to Guile. */
+
+/* scm-exception.c */
+
+extern SCM gdbscm_make_exception (SCM tag, SCM args);
+
+extern int gdbscm_is_exception (SCM scm);
+
+extern SCM gdbscm_exception_key (SCM excp);
+
+extern SCM gdbscm_exception_args (SCM excp);
+
+extern SCM gdbscm_make_exception_with_stack (SCM key, SCM args, SCM stack);
+
+extern SCM gdbscm_make_error_scm (SCM key, SCM subr, SCM message,
+ SCM args, SCM data);
+
+extern SCM gdbscm_make_error (SCM key, const char *subr, const char *message,
+ SCM args, SCM data);
+
+extern SCM gdbscm_make_type_error (const char *subr, int arg_pos,
+ SCM bad_value, const char *expected_type);
+
+extern SCM gdbscm_make_invalid_object_error (const char *subr, int arg_pos,
+ SCM bad_value, const char *error);
+
+extern SCM gdbscm_invalid_object_error (const char *subr, int arg_pos,
+ SCM bad_value, const char *error)
+ ATTRIBUTE_NORETURN;
+
+extern SCM gdbscm_make_out_of_range_error (const char *subr, int arg_pos,
+ SCM bad_value, const char *error);
+
+extern SCM gdbscm_out_of_range_error (const char *subr, int arg_pos,
+ SCM bad_value, const char *error)
+ ATTRIBUTE_NORETURN;
+
+extern SCM gdbscm_make_misc_error (const char *subr, int arg_pos,
+ SCM bad_value, const char *error);
+
+extern void gdbscm_throw (SCM exception) ATTRIBUTE_NORETURN;
+
+extern SCM gdbscm_scm_from_gdb_exception (struct gdb_exception exception);
+
+extern void gdbscm_throw_gdb_exception (struct gdb_exception exception)
+ ATTRIBUTE_NORETURN;
+
+extern void gdbscm_print_exception_message (SCM port, SCM frame, SCM key,
+ SCM args);
+
+extern void gdbscm_print_exception_with_args (SCM port, SCM stack, SCM key,
+ SCM args);
+
+extern void gdbscm_print_exception (SCM port, SCM exception);
+
+extern char *gdbscm_exception_message_to_string (SCM exception);
+
+extern excp_matcher_func gdbscm_memory_error_p;
+
+extern SCM gdbscm_make_memory_error (const char *subr, const char *msg,
+ SCM args);
+
+extern SCM gdbscm_memory_error (const char *subr, const char *msg, SCM args);
+
+/* scm-safe-call.c */
+
+extern void *gdbscm_with_guile (void *(*func) (void *), void *data);
+
+extern SCM gdbscm_call_guile (SCM (*func) (void *), void *data,
+ excp_matcher_func *ok_excps);
+
+extern SCM gdbscm_safe_call_0 (SCM proc, excp_matcher_func *ok_excps);
+
+extern SCM gdbscm_safe_call_1 (SCM proc, SCM arg0,
+ excp_matcher_func *ok_excps);
+
+extern SCM gdbscm_safe_call_2 (SCM proc, SCM arg0, SCM arg1,
+ excp_matcher_func *ok_excps);
+
+extern SCM gdbscm_safe_call_3 (SCM proc, SCM arg0, SCM arg1, SCM arg2,
+ excp_matcher_func *ok_excps);
+
+extern SCM gdbscm_safe_call_4 (SCM proc, SCM arg0, SCM arg1, SCM arg2,
+ SCM arg3,
+ excp_matcher_func *ok_excps);
+
+extern SCM gdbscm_safe_apply_1 (SCM proc, SCM arg0, SCM args,
+ excp_matcher_func *ok_excps);
+
+extern SCM gdbscm_unsafe_call_1 (SCM proc, SCM arg0);
+
+extern char *gdbscm_safe_eval_string (const char *string, int display_result);
+
+extern char *gdbscm_safe_source_script (const char *filename);
+
+extern void gdbscm_enter_repl (void);
+
+/* Interface to various GDB objects, in alphabetical order. */
+
+/* scm-arch.c */
+
+typedef struct _arch_smob arch_smob;
+
+extern struct gdbarch *arscm_get_gdbarch (arch_smob *a_smob);
+
+extern arch_smob *arscm_get_arch_smob_arg_unsafe (SCM arch_scm, int arg_pos,
+ const char *func_name);
+
+extern SCM arscm_scm_from_arch (struct gdbarch *gdbarch);
+
+/* scm-block.c */
+
+extern SCM bkscm_scm_from_block_unsafe (const struct block *block,
+ struct objfile *objfile);
+
+extern const struct block *bkscm_scm_to_block
+ (SCM block_scm, int arg_pos, const char *func_name, SCM *excp);
+
+/* scm-frame.c */
+
+typedef struct _frame_smob frame_smob;
+
+extern int frscm_is_frame (SCM scm);
+
+extern frame_smob *frscm_get_frame_smob_arg_unsafe (SCM frame_scm, int arg_pos,
+ const char *func_name);
+
+extern struct frame_info *frscm_frame_smob_to_frame (frame_smob *);
+
+/* scm-iterator.c */
+
+typedef struct _iterator_smob iterator_smob;
+
+extern SCM itscm_iterator_smob_object (iterator_smob *i_smob);
+
+extern SCM itscm_iterator_smob_progress (iterator_smob *i_smob);
+
+extern void itscm_set_iterator_smob_progress_x (iterator_smob *i_smob,
+ SCM progress);
+
+extern const char *itscm_iterator_smob_name (void);
+
+extern SCM gdbscm_make_iterator (SCM object, SCM progress, SCM next);
+
+extern int itscm_is_iterator (SCM scm);
+
+extern SCM itscm_scm_to_iterator_gsmob (SCM scm);
+
+extern SCM itscm_safe_call_next_x (SCM iter, excp_matcher_func *ok_excps);
+
+extern SCM itscm_get_iterator_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name);
+
+/* scm-lazy-string.c */
+
+extern int lsscm_is_lazy_string (SCM scm);
+
+extern SCM lsscm_scm_to_lazy_string_gsmob (SCM scm);
+
+extern SCM lsscm_make_lazy_string (CORE_ADDR address, int length,
+ const char *encoding, struct type *type);
+
+extern struct value *lsscm_safe_lazy_string_to_value (SCM string,
+ int arg_pos,
+ const char *func_name,
+ SCM *except_scmp);
+
+extern void lsscm_val_print_lazy_string
+ (SCM string, struct ui_file *stream,
+ const struct value_print_options *options);
+
+/* scm-objfile.c */
+
+typedef struct _objfile_smob objfile_smob;
+
+extern SCM ofscm_objfile_smob_pretty_printers (objfile_smob *o_smob);
+
+extern objfile_smob *ofscm_objfile_smob_from_objfile (struct objfile *objfile);
+
+extern SCM ofscm_scm_from_objfile_unsafe (struct objfile *objfile);
+
+/* scm-string.c */
+
+extern char *gdbscm_scm_to_c_string (SCM string);
+
+extern SCM gdbscm_scm_from_c_string (const char *string);
+
+extern SCM gdbscm_scm_from_printf (const char *format, ...);
+
+extern char *gdbscm_scm_to_string (SCM string, size_t *lenp,
+ const char *charset,
+ int strict, SCM *except_scmp);
+
+extern char *gdbscm_scm_to_target_string_unsafe (SCM string, size_t *lenp,
+ struct gdbarch *gdbarch);
+
+/* scm-symbol.c */
+
+extern int syscm_is_symbol (SCM scm);
+
+extern SCM syscm_gsmob_from_symbol (struct symbol *symbol);
+
+extern SCM syscm_scm_from_symbol_unsafe (struct symbol *symbol);
+
+extern SCM syscm_scm_to_symbol_gsmob (SCM scm);
+
+extern struct symbol *syscm_get_valid_symbol_arg_unsafe
+ (SCM self, int arg_pos, const char *func_name);
+
+/* scm-symtab.c */
+
+extern SCM stscm_scm_from_symtab_unsafe (struct symtab *symtab);
+
+extern SCM stscm_scm_from_sal_unsafe (struct symtab_and_line sal);
+
+/* scm-type.c */
+
+typedef struct _type_smob type_smob;
+
+extern int tyscm_is_type (SCM scm);
+
+extern SCM tyscm_scm_from_type_unsafe (struct type *type);
+
+extern type_smob *tyscm_get_type_smob_arg_unsafe (SCM type_scm, int arg_pos,
+ const char *func_name);
+
+extern struct type *tyscm_type_smob_type (type_smob *t_smob);
+
+extern SCM tyscm_gsmob_from_field (SCM type_scm, int field_num);
+
+extern SCM tyscm_scm_from_field_unsafe (SCM type_scm, int field_num);
+
+/* scm-value.c */
+
+extern struct value *vlscm_scm_to_value (SCM scm);
+
+extern int vlscm_is_value (SCM scm);
+
+extern SCM vlscm_scm_from_value (struct value *value);
+
+extern SCM vlscm_scm_from_value_unsafe (struct value *value);
+
+extern SCM vlscm_scm_to_value_gsmob (SCM scm);
+
+extern struct value *vlscm_convert_typed_value_from_scheme
+ (const char *func_name, int obj_arg_pos, SCM obj,
+ int type_arg_pos, SCM type_scm, struct type *type, SCM *except_scmp,
+ struct gdbarch *gdbarch, const struct language_defn *language);
+
+extern struct value *vlscm_convert_value_from_scheme
+ (const char *func_name, int obj_arg_pos, SCM obj, SCM *except_scmp,
+ struct gdbarch *gdbarch, const struct language_defn *language);
+
+/* stript_lang methods */
+
+extern objfile_script_sourcer_func gdbscm_source_objfile_script;
+
+extern int gdbscm_auto_load_enabled (const struct extension_language_defn *);
+
+extern void gdbscm_preserve_values
+ (const struct extension_language_defn *,
+ struct objfile *, htab_t copied_types);
+
+extern enum ext_lang_rc gdbscm_apply_val_pretty_printer
+ (const struct extension_language_defn *,
+ struct type *type, const gdb_byte *valaddr,
+ int embedded_offset, CORE_ADDR address,
+ struct ui_file *stream, int recurse,
+ const struct value *val,
+ const struct value_print_options *options,
+ const struct language_defn *language);
+
+extern int gdbscm_breakpoint_has_cond (const struct extension_language_defn *,
+ struct breakpoint *b);
+
+extern enum ext_lang_bp_stop gdbscm_breakpoint_cond_says_stop
+ (const struct extension_language_defn *, struct breakpoint *b);
+
+/* Initializers for each piece of Scheme support, in alphabetical order. */
+
+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_disasm (void);
+extern void gdbscm_initialize_exceptions (void);
+extern void gdbscm_initialize_frames (void);
+extern void gdbscm_initialize_iterators (void);
+extern void gdbscm_initialize_lazy_strings (void);
+extern void gdbscm_initialize_math (void);
+extern void gdbscm_initialize_objfiles (void);
+extern void gdbscm_initialize_pretty_printers (void);
+extern void gdbscm_initialize_ports (void);
+extern void gdbscm_initialize_smobs (void);
+extern void gdbscm_initialize_strings (void);
+extern void gdbscm_initialize_symbols (void);
+extern void gdbscm_initialize_symtabs (void);
+extern void gdbscm_initialize_types (void);
+extern void gdbscm_initialize_values (void);
+
+/* Use these after a TRY_CATCH to throw the appropriate Scheme exception
+ if a GDB error occurred. */
+
+#define GDBSCM_HANDLE_GDB_EXCEPTION(exception) \
+ do { \
+ if (exception.reason < 0) \
+ { \
+ gdbscm_throw_gdb_exception (exception); \
+ /*NOTREACHED */ \
+ } \
+ } while (0)
+
+/* If cleanups are establish outside the TRY_CATCH block, use this version. */
+
+#define GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS(exception, cleanups) \
+ do { \
+ if (exception.reason < 0) \
+ { \
+ do_cleanups (cleanups); \
+ gdbscm_throw_gdb_exception (exception); \
+ /*NOTREACHED */ \
+ } \
+ } while (0)
+
+#endif /* GDB_GUILE_INTERNAL_H */
diff --git a/gdb/guile/guile.c b/gdb/guile/guile.c
new file mode 100644
index 0000000..2a00142
--- /dev/null
+++ b/gdb/guile/guile.c
@@ -0,0 +1,730 @@
+/* General GDB/Guile code.
+
+ Copyright (C) 2013 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 <string.h>
+#include "breakpoint.h"
+#include "cli/cli-cmds.h"
+#include "cli/cli-script.h"
+#include "cli/cli-utils.h"
+#include "command.h"
+#include "gdbcmd.h"
+#include "interps.h"
+#include "extension-priv.h"
+#include "utils.h"
+#include "version.h"
+#ifdef HAVE_GUILE
+#include "guile.h"
+#include "guile-internal.h"
+#endif
+
+/* Declared constants and enum for guile exception printing. */
+const char gdbscm_print_excp_none[] = "none";
+const char gdbscm_print_excp_full[] = "full";
+const char gdbscm_print_excp_message[] = "message";
+
+/* "set guile print-stack" choices. */
+static const char *const guile_print_excp_enums[] =
+ {
+ gdbscm_print_excp_none,
+ gdbscm_print_excp_full,
+ gdbscm_print_excp_message,
+ NULL
+ };
+
+/* The exception printing variable. 'full' if we want to print the
+ error message and stack, 'none' if we want to print nothing, and
+ 'message' if we only want to print the error message. 'message' is
+ the default. */
+const char *gdbscm_print_excp = gdbscm_print_excp_message;
+
+#ifdef HAVE_GUILE
+/* Forward decls, these are defined later. */
+static const struct extension_language_script_ops guile_extension_script_ops;
+static const struct extension_language_ops guile_extension_ops;
+#endif
+
+/* The main struct describing GDB's interface to the Guile
+ extension language. */
+const struct extension_language_defn extension_language_guile =
+{
+ EXT_LANG_GUILE,
+ "guile",
+ "Guile",
+
+ ".scm",
+ "-gdb.scm",
+
+ guile_control,
+
+#ifdef HAVE_GUILE
+ &guile_extension_script_ops,
+ &guile_extension_ops
+#else
+ NULL,
+ NULL
+#endif
+};
+
+#ifdef HAVE_GUILE
+
+static void gdbscm_finish_initialization
+ (const struct extension_language_defn *);
+static int gdbscm_initialized (const struct extension_language_defn *);
+static void gdbscm_eval_from_control_command
+ (const struct extension_language_defn *, struct command_line *);
+static script_sourcer_func gdbscm_source_script;
+
+int gdb_scheme_initialized;
+
+/* Symbol for setting documentation strings. */
+SCM gdbscm_documentation_symbol;
+
+/* Keywords used by various functions. */
+static SCM from_tty_keyword;
+static SCM to_string_keyword;
+
+/* The name of the various modules (without the surrounding parens). */
+const char gdbscm_module_name[] = "gdb";
+const char gdbscm_init_module_name[] = "gdb init";
+
+/* The name of the bootstrap file. */
+static const char boot_scm_filename[] = "boot.scm";
+
+/* The interface between gdb proper and loading of python scripts. */
+
+static const struct extension_language_script_ops guile_extension_script_ops =
+{
+ gdbscm_source_script,
+ gdbscm_source_objfile_script,
+ gdbscm_auto_load_enabled
+};
+
+/* The interface between gdb proper and guile scripting. */
+
+static const struct extension_language_ops guile_extension_ops =
+{
+ gdbscm_finish_initialization,
+ gdbscm_initialized,
+
+ gdbscm_eval_from_control_command,
+
+ NULL, /* gdbscm_start_type_printers, */
+ NULL, /* gdbscm_apply_type_printers, */
+ NULL, /* gdbscm_free_type_printers, */
+
+ gdbscm_apply_val_pretty_printer,
+
+ NULL, /* gdbscm_apply_frame_filter, */
+
+ gdbscm_preserve_values,
+
+ gdbscm_breakpoint_has_cond,
+ gdbscm_breakpoint_cond_says_stop,
+
+ NULL, /* gdbscm_check_quit_flag, */
+ NULL, /* gdbscm_clear_quit_flag, */
+ NULL, /* gdbscm_set_quit_flag, */
+};
+
+/* Implementation of the gdb "guile-interactive" command. */
+
+static void
+guile_interactive_command (char *arg, int from_tty)
+{
+ struct cleanup *cleanup;
+
+ cleanup = make_cleanup_restore_integer (&interpreter_async);
+ interpreter_async = 0;
+
+ arg = skip_spaces (arg);
+
+ /* This explicitly rejects any arguments for now.
+ "It is easier to relax a restriction than impose one after the fact."
+ We would *like* to be able to pass arguments to the interactive shell
+ but that's not what python-interactive does. Until there is time to
+ sort it out, we forbid arguments. */
+
+ if (arg && *arg)
+ error (_("guile-interactive currently does not take any arguments."));
+ else
+ {
+ dont_repeat ();
+ gdbscm_enter_repl ();
+ }
+
+ do_cleanups (cleanup);
+}
+
+/* Implementation of the gdb "guile" command.
+ Note: Contrary to the Python version this displays the result.
+ Have to see which is better.
+
+ TODO: Add the result to Guile's history? */
+
+static void
+guile_command (char *arg, int from_tty)
+{
+ struct cleanup *cleanup;
+
+ cleanup = make_cleanup_restore_integer (&interpreter_async);
+ interpreter_async = 0;
+
+ arg = skip_spaces (arg);
+
+ if (arg && *arg)
+ {
+ char *msg = gdbscm_safe_eval_string (arg, 1);
+
+ if (msg != NULL)
+ {
+ make_cleanup (xfree, msg);
+ error ("%s", msg);
+ }
+ }
+ else
+ {
+ struct command_line *l = get_command_line (guile_control, "");
+
+ make_cleanup_free_command_lines (&l);
+ execute_control_command_untraced (l);
+ }
+
+ do_cleanups (cleanup);
+}
+
+/* Given a command_line, return a command string suitable for passing
+ to Guile. Lines in the string are separated by newlines. The return
+ value is allocated using xmalloc and the caller is responsible for
+ freeing it. */
+
+static char *
+compute_scheme_string (struct command_line *l)
+{
+ struct command_line *iter;
+ char *script = NULL;
+ int size = 0;
+ int here;
+
+ for (iter = l; iter; iter = iter->next)
+ size += strlen (iter->line) + 1;
+
+ script = xmalloc (size + 1);
+ here = 0;
+ for (iter = l; iter; iter = iter->next)
+ {
+ int len = strlen (iter->line);
+
+ strcpy (&script[here], iter->line);
+ here += len;
+ script[here++] = '\n';
+ }
+ script[here] = '\0';
+ return script;
+}
+
+/* Take a command line structure representing a "guile" command, and
+ evaluate its body using the Guile interpreter.
+ This is the extension_language_ops.eval_from_control_command "method". */
+
+static void
+gdbscm_eval_from_control_command
+ (const struct extension_language_defn *extlang, struct command_line *cmd)
+{
+ char *script, *msg;
+ struct cleanup *cleanup;
+
+ if (cmd->body_count != 1)
+ error (_("Invalid \"guile\" block structure."));
+
+ cleanup = make_cleanup (null_cleanup, NULL);
+
+ script = compute_scheme_string (cmd->body_list[0]);
+ msg = gdbscm_safe_eval_string (script, 0);
+ xfree (script);
+ if (msg != NULL)
+ {
+ make_cleanup (xfree, msg);
+ error ("%s", msg);
+ }
+
+ do_cleanups (cleanup);
+}
+
+/* Read a file as Scheme code.
+ This is the extension_language_script_ops.script_sourcer "method".
+ FILE is the file to run. FILENAME is name of the file FILE.
+ This does not throw any errors. If an exception occurs an error message
+ is printed. */
+
+static void
+gdbscm_source_script (const struct extension_language_defn *extlang,
+ FILE *file, const char *filename)
+{
+ char *msg = gdbscm_safe_source_script (filename);
+
+ if (msg != NULL)
+ {
+ fprintf_filtered (gdb_stderr, "%s\n", msg);
+ xfree (msg);
+ }
+}
+
+/* (execute string [#:from-tty boolean] [#:to-string boolean\
+ A Scheme function which evaluates a string using the gdb CLI. */
+
+static SCM
+gdbscm_execute_gdb_command (SCM command_scm, SCM rest)
+{
+ int from_tty_arg_pos = -1, to_string_arg_pos = -1;
+ int from_tty = 0, to_string = 0;
+ volatile struct gdb_exception except;
+ const SCM keywords[] = { from_tty_keyword, to_string_keyword, SCM_BOOL_F };
+ char *command;
+ char *result = NULL;
+ struct cleanup *cleanups;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#tt",
+ command_scm, &command, rest,
+ &from_tty_arg_pos, &from_tty,
+ &to_string_arg_pos, &to_string);
+
+ /* Note: The contents of "command" may get modified while it is
+ executed. */
+ cleanups = make_cleanup (xfree, command);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct cleanup *inner_cleanups;
+
+ inner_cleanups = make_cleanup_restore_integer (&interpreter_async);
+ interpreter_async = 0;
+
+ prevent_dont_repeat ();
+ if (to_string)
+ result = execute_command_to_string (command, from_tty);
+ else
+ {
+ execute_command (command, from_tty);
+ result = NULL;
+ }
+
+ /* Do any commands attached to breakpoint we stopped at. */
+ bpstat_do_actions ();
+
+ do_cleanups (inner_cleanups);
+ }
+ do_cleanups (cleanups);
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (result)
+ {
+ SCM r = gdbscm_scm_from_c_string (result);
+ xfree (result);
+ return r;
+ }
+ return SCM_UNSPECIFIED;
+}
+
+/* (data-directory) -> string */
+
+static SCM
+gdbscm_data_directory (void)
+{
+ return gdbscm_scm_from_c_string (gdb_datadir);
+}
+
+/* (gdb-version) -> string */
+
+static SCM
+gdbscm_gdb_version (void)
+{
+ return gdbscm_scm_from_c_string (version);
+}
+
+/* (host-config) -> string */
+
+static SCM
+gdbscm_host_config (void)
+{
+ return gdbscm_scm_from_c_string (host_name);
+}
+
+/* (target-config) -> string */
+
+static SCM
+gdbscm_target_config (void)
+{
+ return gdbscm_scm_from_c_string (target_name);
+}
+
+#else /* ! HAVE_GUILE */
+
+/* Dummy implementation of the gdb "guile-interactive" and "guile"
+ commands. */
+
+static void
+guile_interactive_command (char *arg, int from_tty)
+{
+ arg = skip_spaces (arg);
+ if (arg && *arg)
+ error (_("guile-interactive currently does not take any arguments."));
+ error (_("Guile scripting is not supported in this copy of GDB."));
+}
+
+static void
+guile_command (char *arg, int from_tty)
+{
+ arg = skip_spaces (arg);
+ if (arg && *arg)
+ error (_("Guile scripting is not supported in this copy of GDB."));
+ else
+ {
+ /* Even if Guile isn't enabled, we still have to slurp the
+ command list to the corresponding "end". */
+ struct command_line *l = get_command_line (guile_control, "");
+ struct cleanup *cleanups = make_cleanup_free_command_lines (&l);
+
+ execute_control_command_untraced (l);
+ do_cleanups (cleanups);
+ }
+}
+
+#endif /* ! HAVE_GUILE */
+
+/* Lists for 'set,show,info guile' commands. */
+
+static struct cmd_list_element *set_guile_list;
+static struct cmd_list_element *show_guile_list;
+static struct cmd_list_element *info_guile_list;
+
+/* Function for use by 'set guile' prefix command. */
+
+static void
+set_guile_command (char *args, int from_tty)
+{
+ help_list (set_guile_list, "set guile ", all_commands, gdb_stdout);
+}
+
+/* Function for use by 'show guile' prefix command. */
+
+static void
+show_guile_command (char *args, int from_tty)
+{
+ cmd_show_list (show_guile_list, from_tty, "");
+}
+
+/* The "info scheme" command is defined as a prefix, with
+ allow_unknown 0. Therefore, its own definition is called only for
+ "info scheme" with no args. */
+
+static void
+info_guile_command (char *args, int from_tty)
+{
+ printf_unfiltered (_("\"info guile\" must be followed"
+ " by the name of an info command.\n"));
+ help_list (info_guile_list, "info guile ", -1, gdb_stdout);
+}
+
+/* Initialization. */
+
+#ifdef HAVE_GUILE
+
+static const scheme_function misc_guile_functions[] =
+{
+ { "execute", 1, 0, 1, gdbscm_execute_gdb_command,
+ "\
+Execute the given GDB command.\n\
+\n\
+ Arguments: string [#:to-string boolean] [#:from-tty boolean]\n\
+ If #:from-tty is true then the command executes as if entered\n\
+ from the keyboard. The default is false (#f).\n\
+ If #:to-string is true then the result is returned as a string.\n\
+ Otherwise output is sent to the current output port,\n\
+ which is the default.\n\
+ Returns: The result of the command if #:to-string is true.\n\
+ Otherwise returns unspecified." },
+
+ { "data-directory", 0, 0, 0, gdbscm_data_directory,
+ "\
+Return the name of GDB's data directory." },
+
+ { "gdb-version", 0, 0, 0, gdbscm_gdb_version,
+ "\
+Return GDB's version string." },
+
+ { "host-config", 0, 0, 0, gdbscm_host_config,
+ "\
+Return the name of the host configuration." },
+
+ { "target-config", 0, 0, 0, gdbscm_target_config,
+ "\
+Return the name of the target configuration." },
+
+ END_FUNCTIONS
+};
+
+/* Load gdb/boot.scm, the Scheme side of GDB/Guile support.
+ Note: This function assumes it's called within the gdb module. */
+
+static void
+initialize_scheme_side (void)
+{
+ char *gdb_guile_dir = concat (gdb_datadir, SLASH_STRING, "guile", NULL);
+ char *boot_scm_path = concat (gdb_guile_dir, SLASH_STRING, "gdb",
+ SLASH_STRING, boot_scm_filename, NULL);
+ char *msg;
+
+ /* While scm_c_primitive_load works, the loaded code is not compiled,
+ instead it is left to be interpreted. Eh?
+ Anyways, this causes a ~100x slowdown, so we only use it to load
+ gdb/boot.scm, and then let boot.scm do the rest. */
+ msg = gdbscm_safe_source_script (boot_scm_path);
+
+ if (msg != NULL)
+ {
+ fprintf_filtered (gdb_stderr, "%s", msg);
+ xfree (msg);
+ warning (_("\n"
+ "Could not complete Guile gdb module initialization from:\n"
+ "%s.\n"
+ "Limited Guile support is available.\n"
+ "Suggest passing --data-directory=/path/to/gdb/data-directory.\n"),
+ boot_scm_path);
+ }
+
+ xfree (gdb_guile_dir);
+ xfree (boot_scm_path);
+}
+
+/* Install the gdb scheme module.
+ The result is a boolean indicating success.
+ If initializing the gdb module fails an error message is printed.
+ Note: This function runs in the context of the gdb module. */
+
+static void
+initialize_gdb_module (void *data)
+{
+ /* The documentation symbol needs to be defined before any calls to
+ gdbscm_define_{variables,functions}. */
+ gdbscm_documentation_symbol = gdbscm_symbol_from_c_string ("documentation");
+
+ /* The smob and exception support must be initialized early. */
+ gdbscm_initialize_smobs ();
+ gdbscm_initialize_exceptions ();
+
+ /* The rest are initialized in alphabetical order. */
+ gdbscm_initialize_arches ();
+ gdbscm_initialize_auto_load ();
+ gdbscm_initialize_blocks ();
+ gdbscm_initialize_breakpoints ();
+ gdbscm_initialize_disasm ();
+ gdbscm_initialize_frames ();
+ gdbscm_initialize_iterators ();
+ gdbscm_initialize_lazy_strings ();
+ gdbscm_initialize_math ();
+ gdbscm_initialize_objfiles ();
+ gdbscm_initialize_ports ();
+ gdbscm_initialize_pretty_printers ();
+ gdbscm_initialize_strings ();
+ gdbscm_initialize_symbols ();
+ gdbscm_initialize_symtabs ();
+ gdbscm_initialize_types ();
+ gdbscm_initialize_values ();
+
+ gdbscm_define_functions (misc_guile_functions, 1);
+
+ from_tty_keyword = scm_from_latin1_keyword ("from-tty");
+ to_string_keyword = scm_from_latin1_keyword ("to-string");
+
+ initialize_scheme_side ();
+
+ gdb_scheme_initialized = 1;
+}
+
+/* A callback to finish Guile initialization after gdb has finished all its
+ initialization.
+ This is the extension_language_ops.finish_initialization "method". */
+
+static void
+gdbscm_finish_initialization (const struct extension_language_defn *extlang)
+{
+ /* Restore the environment to the user interaction one. */
+ scm_set_current_module (scm_interaction_environment ());
+}
+
+/* The extension_language_ops.initialized "method". */
+
+static int
+gdbscm_initialized (const struct extension_language_defn *extlang)
+{
+ return gdb_scheme_initialized;
+}
+
+/* Enable or disable Guile backtraces. */
+
+static void
+gdbscm_set_backtrace (int enable)
+{
+ static const char disable_bt[] = "(debug-disable 'backtrace)";
+ static const char enable_bt[] = "(debug-enable 'backtrace)";
+
+ if (enable)
+ gdbscm_safe_eval_string (enable_bt, 0);
+ else
+ gdbscm_safe_eval_string (disable_bt, 0);
+}
+
+#endif /* HAVE_GUILE */
+
+/* Install the various gdb commands used by Guile. */
+
+static void
+install_gdb_commands (void)
+{
+ add_com ("guile-interactive", class_obscure,
+ guile_interactive_command,
+#ifdef HAVE_GUILE
+ _("\
+Start an interactive Guile prompt.\n\
+\n\
+To return to GDB, type the EOF character (e.g., Ctrl-D on an empty\n\
+prompt).\n\
+\n\
+Alternatively, a single-line Guile command can be given as an\n\
+argument, and if the command is an expression, the result will be\n\
+printed. For example:\n\
+\n\
+ (gdb) scheme-interactive (2 + 3)\n\
+ 5\n\
+")
+#else /* HAVE_GUILE */
+ _("\
+Start a Guile interactive prompt.\n\
+\n\
+Guile scripting is not supported in this copy of GDB.\n\
+This command is only a placeholder.")
+#endif /* HAVE_GUILE */
+ );
+ add_com_alias ("gi", "guile-interactive", class_obscure, 1);
+
+ /* Since "help guile" is easy to type, and intuitive, we add general help
+ in using GDB+Guile to this command. */
+ add_com ("guile", class_obscure, guile_command,
+#ifdef HAVE_GUILE
+ _("\
+Evaluate a Guile command.\n\
+\n\
+The command can be given as an argument, for instance:\n\
+\n\
+ guile (display 23)\n\
+\n\
+If no argument is given, the following lines are read and used\n\
+as the Guile commands. Type a line containing \"end\" to indicate\n\
+the end of the command.\n\
+\n\
+The Guile GDB module must first be imported before it can be used.\n\
+Do this with:\n\
+(gdb) guile (use-modules (gdb))\n\
+or if you want to import the (gdb) module with a prefix, use:\n\
+(gdb) guile (use-modules ((gdb) #:renamer (symbol-prefix-proc 'gdb:)))\n\
+\n\
+The Guile interactive session, started with the \"guile-interactive\"\n\
+command, provides extensive help and apropos capabilities.\n\
+Type \",help\" once in a Guile interactive session.")
+#else /* HAVE_GUILE */
+ _("\
+Evaluate a Guile command.\n\
+\n\
+Guile scripting is not supported in this copy of GDB.\n\
+This command is only a placeholder.")
+#endif /* HAVE_GUILE */
+ );
+ add_com_alias ("gu", "guile", class_obscure, 1);
+
+ add_prefix_cmd ("guile", class_obscure, set_guile_command,
+ _("Prefix command for Guile preference settings."),
+ &set_guile_list, "set guile ", 0,
+ &setlist);
+ add_alias_cmd ("gu", "guile", class_obscure, 1, &setlist);
+
+ add_prefix_cmd ("guile", class_obscure, show_guile_command,
+ _("Prefix command for Guile preference settings."),
+ &show_guile_list, "show guile ", 0,
+ &showlist);
+ add_alias_cmd ("gu", "guile", class_obscure, 1, &showlist);
+
+ add_prefix_cmd ("guile", class_obscure, info_guile_command,
+ _("Prefix command for Guile info displays."),
+ &info_guile_list, "info guile ", 0,
+ &infolist);
+ add_info_alias ("gu", "guile", 1);
+
+ /* The name "print-stack" is carried over from Python.
+ A better name is "print-exception". */
+ add_setshow_enum_cmd ("print-stack", no_class, guile_print_excp_enums,
+ &gdbscm_print_excp, _("\
+Set mode for Guile exception printing on error."), _("\
+Show the mode of Guile exception printing on error."), _("\
+none == no stack or message will be printed.\n\
+full == a message and a stack will be printed.\n\
+message == an error message without a stack will be printed."),
+ NULL, NULL,
+ &set_guile_list, &show_guile_list);
+}
+
+/* Provide a prototype to silence -Wmissing-prototypes. */
+extern initialize_file_ftype _initialize_guile;
+
+void
+_initialize_guile (void)
+{
+ char *msg;
+
+ install_gdb_commands ();
+
+#if HAVE_GUILE
+ /* The Guile docs say scm_init_guile isn't as portable as the other Guile
+ initialization routines. However, this is the easiest to use.
+ We can switch to a more portable routine if/when the need arises
+ and if it can be used with gdb. */
+ scm_init_guile ();
+
+ /* The Python support puts the C side in module "_gdb", leaving the Python
+ side to define module "gdb" which imports "_gdb". There is evidently no
+ similar convention in Guile so we skip this. */
+
+ /* The rest of the initialization is done by initialize_gdb_module.
+ scm_c_define_module is used as it allows us to perform the initialization
+ within the desired module. */
+ scm_c_define_module (gdbscm_module_name, initialize_gdb_module, NULL);
+
+ /* Set Guile's backtrace to match the "set guile print-stack" default.
+ [N.B. The two settings are still separate.]
+ But only do this after we've initialized Guile, it's nice to see a
+ backtrace if there's an error during initialization.
+ OTOH, if the error is that gdb/init.scm wasn't found because gdb is being
+ run from the build tree, the backtrace is more noise than signal.
+ Sigh. */
+ gdbscm_set_backtrace (0);
+#endif
+}
diff --git a/gdb/guile/guile.h b/gdb/guile/guile.h
new file mode 100644
index 0000000..f507c58
--- /dev/null
+++ b/gdb/guile/guile.h
@@ -0,0 +1,28 @@
+/* General GDB/Scheme code.
+
+ Copyright (C) 2013 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/>. */
+
+#ifndef GDB_GUILE_H
+#define GDB_GUILE_H
+
+#include "extension.h"
+
+/* This is all that guile exports to gdb. */
+extern const struct extension_language_defn extension_language_guile;
+
+#endif /* GDB_GUILE_H */
diff --git a/gdb/testsuite/gdb.guile/guile.exp b/gdb/testsuite/gdb.guile/guile.exp
new file mode 100644
index 0000000..df1ab62
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/guile.exp
@@ -0,0 +1,77 @@
+# Copyright (C) 2008-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 basic Guile features.
+
+load_lib gdb-guile.exp
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+gdb_reinitialize_dir $srcdir/$subdir
+
+# Do this instead of the skip_guile_check.
+# We want to do some tests when Guile is not present.
+gdb_test_multiple "guile (display 23) (newline)" "verify guile support" {
+ -re "Undefined command.*$gdb_prompt $" {
+ unsupported "Guile not supported."
+ return
+ }
+ -re "not supported.*$gdb_prompt $" {
+ unsupported "guile support is disabled"
+
+ # If Guile is not supported, verify that sourcing a guile script
+ # causes an error.
+ gdb_test "source $srcdir/$subdir/source2.scm" \
+ "Error in sourced command file:.*" \
+ "source source2.scm when guile disabled"
+ return
+ }
+ -re "$gdb_prompt $" {}
+}
+
+gdb_install_guile_utils
+gdb_install_guile_module
+
+gdb_test_multiline "multi-line guile command" \
+ "guile" "" \
+ "(print 23)" "" \
+ "end" "= 23"
+
+gdb_test_multiline "show guile command" \
+ "define zzq" "Type commands for definition of .* just \"end\"\\.*" \
+ "guile" "" \
+ "(print 23)" "" \
+ "end" "" \
+ "end" "" \
+ "show user zzq" "User command \"zzq\":.* guile.*\\(print 23\\).* end"
+
+gdb_test "source $srcdir/$subdir/source2.scm" "yes" "source source2.scm"
+
+gdb_test "source -s source2.scm" "yes" "source -s source2.scm"
+
+gdb_test "guile (print (current-objfile))" "= #f"
+gdb_test "guile (print (objfiles))" "= \\(\\)"
+
+gdb_test_no_output \
+ {guile (define x (execute "printf \"%d\", 23" #:to-string #t))}
+gdb_test "guile (print x)" "= 23"
+
+gdb_test_no_output "guile (define a (execute \"help\" #:to-string #t))" \
+ "collect help from uiout"
+
+gdb_test "guile (print a)" "= .*aliases -- Aliases of other commands.*" \
+ "verify help to uiout"
diff --git a/gdb/testsuite/gdb.guile/source2.scm b/gdb/testsuite/gdb.guile/source2.scm
new file mode 100644
index 0000000..09ef25d
--- /dev/null
+++ b/gdb/testsuite/gdb.guile/source2.scm
@@ -0,0 +1,19 @@
+;; This testcase is part of GDB, the GNU debugger.
+;;
+;; Copyright 2008-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/>.
+
+(display (format "y~As" "e"))
+(newline)