* NEWS: Mention Guile scripting.
* Makefile.in (SUBDIR_GUILE_OBS): New variable.
(SUBDIR_GUILE_SRCS, SUBDIR_GUILE_DEPS): New variables
(SUBDIR_GUILE_LDFLAGS, SUBDIR_GUILE_CFLAGS): New variables.
(INTERNAL_CPPFLAGS): Add GUILE_CPPFLAGS.
(CLIBS): Add GUILE_LIBS.
(install-guile): New rule.
(guile.o): New rule.
(scm-arch.o, scm-auto-load.o, scm-block.o): New rules.
(scm-breakpoint.o, scm-disasm.o, scm-exception.o): New rules.
(scm-frame.o, scm-iterator.o, scm-lazy-string.o): New rules.
(scm-math.o, scm-objfile.o, scm-ports.o): New rules.
(scm-pretty-print.o, scm-safe-call.o, scm-gsmob.o): New rules.
(scm-string.o, scm-symbol.o, scm-symtab.o): New rules.
(scm-type.o, scm-utils.o, scm-value.o): New rules.
* configure.ac: New option --with-guile.
* configure: Regenerate.
* config.in: Regenerate.
* auto-load.c: Remove #include "python/python.h". Add #include
"gdb/section-scripts.h".
(source_section_scripts): Handle Guile scripts.
(_initialize_auto_load): Add name of Guile objfile script to
scripts-directory help text.
* breakpoint.c (condition_command): Tweak comment to include Scheme.
* breakpoint.h (gdbscm_breakpoint_object): Add forward decl.
(struct breakpoint): New member scm_bp_object.
* defs.h (enum command_control_type): New value guile_control.
* cli/cli-cmds.c: Remove #include "python/python.h". Add #include
"extension.h".
(show_user): Update comment.
(_initialize_cli_cmds): Update help text for "show user". Update help
text for max-user-call-depth.
* cli/cli-script.c: Remove #include "python/python.h". Add #include
"extension.h".
(multi_line_command_p): Add guile_control.
(print_command_lines): Handle guile_control.
(execute_control_command, recurse_read_control_structure): Ditto.
(process_next_line): Recognize "guile" commands.
* disasm.c (gdb_disassemble_info): Make non-static.
* disasm.h: #include "dis-asm.h".
(struct gdbarch): Add forward decl.
(gdb_disassemble_info): Declare.
* extension.c: #include "guile/guile.h".
(extension_languages): Add guile.
(get_ext_lang_defn): Handle EXT_LANG_GDB.
* extension.h (enum extension_language): New value EXT_LANG_GUILE.
* gdbtypes.c (get_unsigned_type_max): New function.
(get_signed_type_minmax): New function.
* gdbtypes.h (get_unsigned_type_max): Declare.
(get_signed_type_minmax): Declare.
* guile/README: New file.
* guile/guile-internal.h: New file.
* guile/guile.c: New file.
* guile/guile.h: New file.
* guile/scm-arch.c: New file.
* guile/scm-auto-load.c: New file.
* guile/scm-block.c: New file.
* guile/scm-breakpoint.c: New file.
* guile/scm-disasm.c: New file.
* guile/scm-exception.c: New file.
* guile/scm-frame.c: New file.
* guile/scm-gsmob.c: New file.
* guile/scm-iterator.c: New file.
* guile/scm-lazy-string.c: New file.
* guile/scm-math.c: New file.
* guile/scm-objfile.c: New file.
* guile/scm-ports.c: New file.
* guile/scm-pretty-print.c: New file.
* guile/scm-safe-call.c: New file.
* guile/scm-string.c: New file.
* guile/scm-symbol.c: New file.
* guile/scm-symtab.c: New file.
* guile/scm-type.c: New file.
* guile/scm-utils.c: New file.
* guile/scm-value.c: New file.
* guile/lib/gdb.scm: New file.
* guile/lib/gdb/boot.scm: New file.
* guile/lib/gdb/experimental.scm: New file.
* guile/lib/gdb/init.scm: New file.
* guile/lib/gdb/iterator.scm: New file.
* guile/lib/gdb/printing.scm: New file.
* guile/lib/gdb/types.scm: New file.
* data-directory/Makefile.in (GUILE_SRCDIR): New variable.
(VPATH): Add $(GUILE_SRCDIR).
(GUILE_DIR): New variable.
(GUILE_INSTALL_DIR, GUILE_FILES): New variables.
(all): Add stamp-guile dependency.
(stamp-guile): New rule.
(clean-guile, install-guile, uninstall-guile): New rules.
(install-only): Add install-guile dependency.
(uninstall): Add uninstall-guile dependency.
(clean): Add clean-guile dependency.
doc/
* Makefile.in (GDB_DOC_FILES): Add guile.texi.
* gdb.texinfo (Auto-loading): Add set/show auto-load guile-scripts.
(Extending GDB): New menu entries Guile, Multiple Extension Languages.
(Guile docs): Include guile.texi.
(objfile-gdbdotext file): Add objfile-gdb.scm.
(dotdebug_gdb_scripts section): Mention Guile scripts.
(Multiple Extension Languages): New node.
* guile.texi: New file.
testsuite/
* configure.ac (AC_OUTPUT): Add gdb.guile.
* configure: Regenerate.
* lib/gdb-guile.exp: New file.
* lib/gdb.exp (get_target_charset): New function.
* gdb.base/help.exp: Update expected output from "apropos apropos".
* gdb.guile/Makefile.in: New file.
* gdb.guile/guile.exp: New file.
* gdb.guile/scm-arch.c: New file.
* gdb.guile/scm-arch.exp: New file.
* gdb.guile/scm-block.c: New file.
* gdb.guile/scm-block.exp: New file.
* gdb.guile/scm-breakpoint.c: New file.
* gdb.guile/scm-breakpoint.exp: New file.
* gdb.guile/scm-disasm.c: New file.
* gdb.guile/scm-disasm.exp: New file.
* gdb.guile/scm-equal.c: New file.
* gdb.guile/scm-equal.exp: New file.
* gdb.guile/scm-error.exp: New file.
* gdb.guile/scm-error.scm: New file.
* gdb.guile/scm-frame-args.c: New file.
* gdb.guile/scm-frame-args.exp: New file.
* gdb.guile/scm-frame-args.scm: New file.
* gdb.guile/scm-frame-inline.c: New file.
* gdb.guile/scm-frame-inline.exp: New file.
* gdb.guile/scm-frame.c: New file.
* gdb.guile/scm-frame.exp: New file.
* gdb.guile/scm-generics.exp: New file.
* gdb.guile/scm-gsmob.exp: New file.
* gdb.guile/scm-iterator.c: New file.
* gdb.guile/scm-iterator.exp: New file.
* gdb.guile/scm-math.c: New file.
* gdb.guile/scm-math.exp: New file.
* gdb.guile/scm-objfile-script-gdb.in: New file.
* gdb.guile/scm-objfile-script.c: New file.
* gdb.guile/scm-objfile-script.exp: New file.
* gdb.guile/scm-objfile.c: New file.
* gdb.guile/scm-objfile.exp: New file.
* gdb.guile/scm-ports.exp: New file.
* gdb.guile/scm-pretty-print.c: New file.
* gdb.guile/scm-pretty-print.exp: New file.
* gdb.guile/scm-pretty-print.scm: New file.
* gdb.guile/scm-section-script.c: New file.
* gdb.guile/scm-section-script.exp: New file.
* gdb.guile/scm-section-script.scm: New file.
* gdb.guile/scm-symbol.c: New file.
* gdb.guile/scm-symbol.exp: New file.
* gdb.guile/scm-symtab-2.c: New file.
* gdb.guile/scm-symtab.c: New file.
* gdb.guile/scm-symtab.exp: New file.
* gdb.guile/scm-type.c: New file.
* gdb.guile/scm-type.exp: New file.
* gdb.guile/scm-value-cc.cc: New file.
* gdb.guile/scm-value-cc.exp: New file.
* gdb.guile/scm-value.c: New file.
* gdb.guile/scm-value.exp: New file.
* gdb.guile/source2.scm: New file.
* gdb.guile/types-module.cc: New file.
* gdb.guile/types-module.exp: New file.
+2014-02-10 Doug Evans <xdje42@gmail.com>
+
+ Add Guile as an extension language.
+ * NEWS: Mention Guile scripting.
+ * Makefile.in (SUBDIR_GUILE_OBS): New variable.
+ (SUBDIR_GUILE_SRCS, SUBDIR_GUILE_DEPS): New variables
+ (SUBDIR_GUILE_LDFLAGS, SUBDIR_GUILE_CFLAGS): New variables.
+ (INTERNAL_CPPFLAGS): Add GUILE_CPPFLAGS.
+ (CLIBS): Add GUILE_LIBS.
+ (install-guile): New rule.
+ (guile.o): New rule.
+ (scm-arch.o, scm-auto-load.o, scm-block.o): New rules.
+ (scm-breakpoint.o, scm-disasm.o, scm-exception.o): New rules.
+ (scm-frame.o, scm-iterator.o, scm-lazy-string.o): New rules.
+ (scm-math.o, scm-objfile.o, scm-ports.o): New rules.
+ (scm-pretty-print.o, scm-safe-call.o, scm-gsmob.o): New rules.
+ (scm-string.o, scm-symbol.o, scm-symtab.o): New rules.
+ (scm-type.o, scm-utils.o, scm-value.o): New rules.
+ * configure.ac: New option --with-guile.
+ * configure: Regenerate.
+ * config.in: Regenerate.
+ * auto-load.c: Remove #include "python/python.h". Add #include
+ "gdb/section-scripts.h".
+ (source_section_scripts): Handle Guile scripts.
+ (_initialize_auto_load): Add name of Guile objfile script to
+ scripts-directory help text.
+ * breakpoint.c (condition_command): Tweak comment to include Scheme.
+ * breakpoint.h (gdbscm_breakpoint_object): Add forward decl.
+ (struct breakpoint): New member scm_bp_object.
+ * defs.h (enum command_control_type): New value guile_control.
+ * cli/cli-cmds.c: Remove #include "python/python.h". Add #include
+ "extension.h".
+ (show_user): Update comment.
+ (_initialize_cli_cmds): Update help text for "show user". Update help
+ text for max-user-call-depth.
+ * cli/cli-script.c: Remove #include "python/python.h". Add #include
+ "extension.h".
+ (multi_line_command_p): Add guile_control.
+ (print_command_lines): Handle guile_control.
+ (execute_control_command, recurse_read_control_structure): Ditto.
+ (process_next_line): Recognize "guile" commands.
+ * disasm.c (gdb_disassemble_info): Make non-static.
+ * disasm.h: #include "dis-asm.h".
+ (struct gdbarch): Add forward decl.
+ (gdb_disassemble_info): Declare.
+ * extension.c: #include "guile/guile.h".
+ (extension_languages): Add guile.
+ (get_ext_lang_defn): Handle EXT_LANG_GDB.
+ * extension.h (enum extension_language): New value EXT_LANG_GUILE.
+ * gdbtypes.c (get_unsigned_type_max): New function.
+ (get_signed_type_minmax): New function.
+ * gdbtypes.h (get_unsigned_type_max): Declare.
+ (get_signed_type_minmax): Declare.
+ * guile/README: New file.
+ * guile/guile-internal.h: New file.
+ * guile/guile.c: New file.
+ * guile/guile.h: New file.
+ * guile/scm-arch.c: New file.
+ * guile/scm-auto-load.c: New file.
+ * guile/scm-block.c: New file.
+ * guile/scm-breakpoint.c: New file.
+ * guile/scm-disasm.c: New file.
+ * guile/scm-exception.c: New file.
+ * guile/scm-frame.c: New file.
+ * guile/scm-gsmob.c: New file.
+ * guile/scm-iterator.c: New file.
+ * guile/scm-lazy-string.c: New file.
+ * guile/scm-math.c: New file.
+ * guile/scm-objfile.c: New file.
+ * guile/scm-ports.c: New file.
+ * guile/scm-pretty-print.c: New file.
+ * guile/scm-safe-call.c: New file.
+ * guile/scm-string.c: New file.
+ * guile/scm-symbol.c: New file.
+ * guile/scm-symtab.c: New file.
+ * guile/scm-type.c: New file.
+ * guile/scm-utils.c: New file.
+ * guile/scm-value.c: New file.
+ * guile/lib/gdb.scm: New file.
+ * guile/lib/gdb/boot.scm: New file.
+ * guile/lib/gdb/experimental.scm: New file.
+ * guile/lib/gdb/init.scm: New file.
+ * guile/lib/gdb/iterator.scm: New file.
+ * guile/lib/gdb/printing.scm: New file.
+ * guile/lib/gdb/types.scm: New file.
+ * data-directory/Makefile.in (GUILE_SRCDIR): New variable.
+ (VPATH): Add $(GUILE_SRCDIR).
+ (GUILE_DIR): New variable.
+ (GUILE_INSTALL_DIR, GUILE_FILES): New variables.
+ (all): Add stamp-guile dependency.
+ (stamp-guile): New rule.
+ (clean-guile, install-guile, uninstall-guile): New rules.
+ (install-only): Add install-guile dependency.
+ (uninstall): Add uninstall-guile dependency.
+ (clean): Add clean-guile dependency.
+
2014-02-09 Doug Evans <xdje42@gmail.com>
Revert this patch (which I approved, mea culpa).
SUBDIR_TUI_CFLAGS= \
-DTUI=1
+# Guile sub directory definitons for guile support.
+
+SUBDIR_GUILE_OBS = \
+ guile.o \
+ scm-arch.o \
+ scm-auto-load.o \
+ scm-block.o \
+ scm-breakpoint.o \
+ scm-disasm.o \
+ scm-exception.o \
+ scm-frame.o \
+ scm-iterator.o \
+ scm-lazy-string.o \
+ scm-objfile.o \
+ scm-math.o \
+ scm-ports.o \
+ scm-pretty-print.o \
+ scm-safe-call.o \
+ scm-gsmob.o \
+ scm-string.o \
+ scm-symbol.o \
+ scm-symtab.o \
+ scm-type.o \
+ scm-utils.o \
+ scm-value.o
+SUBDIR_GUILE_SRCS = \
+ guile/guile.c \
+ guile/scm-arch.c \
+ guile/scm-auto-load.c \
+ guile/scm-block.c \
+ guile/scm-breakpoint.c \
+ guile/scm-disasm.c \
+ guile/scm-exception.c \
+ guile/scm-frame.c \
+ guile/scm-iterator.c \
+ guile/scm-lazy-string.c \
+ guile/scm-objfile.c \
+ guile/scm-math.c \
+ guile/scm-ports.c \
+ guile/scm-pretty-print.c \
+ guile/scm-safe-call.c \
+ guile/scm-gsmob.c \
+ guile/scm-string.c \
+ guile/scm-symbol.c \
+ guile/scm-symtab.c \
+ guile/scm-type.c \
+ guile/scm-utils.c \
+ guile/scm-value.c
+SUBDIR_GUILE_DEPS =
+SUBDIR_GUILE_LDFLAGS=
+SUBDIR_GUILE_CFLAGS=
+
#
# python sub directory definitons
#
# are sometimes a little generic, we think that the risk of collision
# with other header files is high. If that happens, we try to mitigate
# a bit the consequences by putting the Python includes last in the list.
-INTERNAL_CPPFLAGS = @CPPFLAGS@ @PYTHON_CPPFLAGS@
+INTERNAL_CPPFLAGS = @CPPFLAGS@ @GUILE_CPPFLAGS@ @PYTHON_CPPFLAGS@
# Need to pass this to testsuite for "make check". Probably should be
# consistent with top-level Makefile.in and gdb/testsuite/Makefile.in
# XM_CLIBS, defined in *config files, have host-dependent libs.
# LIBIBERTY appears twice on purpose.
CLIBS = $(SIM) $(READLINE) $(OPCODES) $(BFD) $(INTL) $(LIBIBERTY) $(LIBDECNUMBER) \
- $(XM_CLIBS) $(NAT_CLIBS) $(GDBTKLIBS) @LIBS@ @PYTHON_LIBS@ \
+ $(XM_CLIBS) $(NAT_CLIBS) $(GDBTKLIBS) \
+ @LIBS@ @GUILE_LIBS@ @PYTHON_LIBS@ \
$(LIBEXPAT) $(LIBLZMA) $(LIBBABELTRACE) \
$(LIBIBERTY) $(WIN32LIBS) $(LIBGNU)
CDEPS = $(XM_CDEPS) $(NAT_CDEPS) $(SIM) $(BFD) $(READLINE_DEPS) \
`test -z '$(STRIP)' || \
echo "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'"` install-only
+install-guile:
+ $(SHELL) $(srcdir)/../mkinstalldirs $(DESTDIR)$(GDB_DATADIR)/guile/gdb
+
install-python:
$(SHELL) $(srcdir)/../mkinstalldirs $(DESTDIR)$(GDB_DATADIR)/python/gdb
$(COMPILE) $(srcdir)/tui/tui-winsource.c
$(POSTCOMPILE)
+# gdb/guile dependencies
#
+# Need to explicitly specify the compile rule as make will do nothing
+# or try to compile the object file into the sub-directory.
+
+guile.o: $(srcdir)/guile/guile.c
+ $(COMPILE) $(srcdir)/guile/guile.c
+ $(POSTCOMPILE)
+
+scm-arch.o: $(srcdir)/guile/scm-arch.c
+ $(COMPILE) $(srcdir)/guile/scm-arch.c
+ $(POSTCOMPILE)
+
+scm-auto-load.o: $(srcdir)/guile/scm-auto-load.c
+ $(COMPILE) $(srcdir)/guile/scm-auto-load.c
+ $(POSTCOMPILE)
+
+scm-block.o: $(srcdir)/guile/scm-block.c
+ $(COMPILE) $(srcdir)/guile/scm-block.c
+ $(POSTCOMPILE)
+
+scm-breakpoint.o: $(srcdir)/guile/scm-breakpoint.c
+ $(COMPILE) $(srcdir)/guile/scm-breakpoint.c
+ $(POSTCOMPILE)
+
+scm-disasm.o: $(srcdir)/guile/scm-disasm.c
+ $(COMPILE) $(srcdir)/guile/scm-disasm.c
+ $(POSTCOMPILE)
+
+scm-exception.o: $(srcdir)/guile/scm-exception.c
+ $(COMPILE) $(srcdir)/guile/scm-exception.c
+ $(POSTCOMPILE)
+
+scm-frame.o: $(srcdir)/guile/scm-frame.c
+ $(COMPILE) $(srcdir)/guile/scm-frame.c
+ $(POSTCOMPILE)
+
+scm-iterator.o: $(srcdir)/guile/scm-iterator.c
+ $(COMPILE) $(srcdir)/guile/scm-iterator.c
+ $(POSTCOMPILE)
+
+scm-lazy-string.o: $(srcdir)/guile/scm-lazy-string.c
+ $(COMPILE) $(srcdir)/guile/scm-lazy-string.c
+ $(POSTCOMPILE)
+
+scm-math.o: $(srcdir)/guile/scm-math.c
+ $(COMPILE) $(srcdir)/guile/scm-math.c
+ $(POSTCOMPILE)
+
+scm-objfile.o: $(srcdir)/guile/scm-objfile.c
+ $(COMPILE) $(srcdir)/guile/scm-objfile.c
+ $(POSTCOMPILE)
+
+scm-ports.o: $(srcdir)/guile/scm-ports.c
+ $(COMPILE) $(srcdir)/guile/scm-ports.c
+ $(POSTCOMPILE)
+
+scm-pretty-print.o: $(srcdir)/guile/scm-pretty-print.c
+ $(COMPILE) $(srcdir)/guile/scm-pretty-print.c
+ $(POSTCOMPILE)
+
+scm-safe-call.o: $(srcdir)/guile/scm-safe-call.c
+ $(COMPILE) $(srcdir)/guile/scm-safe-call.c
+ $(POSTCOMPILE)
+
+scm-gsmob.o: $(srcdir)/guile/scm-gsmob.c
+ $(COMPILE) $(srcdir)/guile/scm-gsmob.c
+ $(POSTCOMPILE)
+
+scm-string.o: $(srcdir)/guile/scm-string.c
+ $(COMPILE) $(srcdir)/guile/scm-string.c
+ $(POSTCOMPILE)
+
+scm-symbol.o: $(srcdir)/guile/scm-symbol.c
+ $(COMPILE) $(srcdir)/guile/scm-symbol.c
+ $(POSTCOMPILE)
+
+scm-symtab.o: $(srcdir)/guile/scm-symtab.c
+ $(COMPILE) $(srcdir)/guile/scm-symtab.c
+ $(POSTCOMPILE)
+
+scm-type.o: $(srcdir)/guile/scm-type.c
+ $(COMPILE) $(srcdir)/guile/scm-type.c
+ $(POSTCOMPILE)
+
+scm-utils.o: $(srcdir)/guile/scm-utils.c
+ $(COMPILE) $(srcdir)/guile/scm-utils.c
+ $(POSTCOMPILE)
+
+scm-value.o: $(srcdir)/guile/scm-value.c
+ $(COMPILE) $(srcdir)/guile/scm-value.c
+ $(POSTCOMPILE)
+
# gdb/python/ dependencies
#
# Need to explicitly specify the compile rule as make will do nothing
*** Changes since GDB 7.7
+* Guile scripting
+
+ GDB now has support for scripting using Guile. Whether this is
+ available is determined at configure time.
+ Guile version 2.0 or greater is required.
+ Guile version 2.0.9 is well tested, earlier 2.0 versions are not.
+
+* New commands (for set/show, see "New options" below)
+
+guile [code]
+gu [code]
+ Invoke CODE by passing it to the Guile interpreter.
+
+guile-repl
+gr
+ Start a Guile interactive prompt (or "repl" for "read-eval-print loop").
+
+info auto-load guile-scripts [regexp]
+ Print the list of automatically loaded Guile scripts.
+
+* The source command is now capable of sourcing Guile scripts.
+ This feature is dependent on the debugger being built with Guile support.
+
* New options
+set guile print-stack (none|message|full)
+show guile print-stack
+ Show a stack trace when an error is encountered in a Guile script.
+
+set auto-load guile-scripts (on|off)
+show auto-load guile-scripts
+ Control auto-loading of Guile script files.
+
maint ada set ignore-descriptive-types (on|off)
maint ada show ignore-descriptive-types
Control whether the debugger should ignore descriptive types in Ada
#include "top.h"
#include "filestuff.h"
#include "extension.h"
-#include "python/python.h"
+#include "gdb/section-scripts.h"
/* The section to look in for auto-loaded scripts (in file formats that
support sections).
char *full_path;
int opened, in_hash_table;
struct cleanup *back_to;
- /* At the moment we only support python scripts in .debug_gdb_scripts,
- but that can change. */
- const struct extension_language_defn *language
- = &extension_language_python;
+ const struct extension_language_defn *language;
objfile_script_sourcer_func *sourcer;
- if (*p != 1)
+ switch (*p)
{
+ case SECTION_SCRIPT_ID_PYTHON_FILE:
+ language = get_ext_lang_defn (EXT_LANG_PYTHON);
+ break;
+ case SECTION_SCRIPT_ID_SCHEME_FILE:
+ language = get_ext_lang_defn (EXT_LANG_GUILE);
+ break;
+ default:
warning (_("Invalid entry in %s section"), section_name);
/* We could try various heuristics to find the next valid entry,
but it's safer to just punt. */
- break;
+ return;
}
file = ++p;
{
struct cmd_list_element *cmd;
char *scripts_directory_help, *gdb_name_help, *python_name_help;
+ char *guile_name_help;
+ const char *suffix;
auto_load_pspace_data
= register_program_space_data_with_cleanup (NULL,
auto_load_dir = xstrdup (AUTO_LOAD_DIR);
+ suffix = ext_lang_auto_load_suffix (get_ext_lang_defn (EXT_LANG_GDB));
gdb_name_help
= xstrprintf (_("\
GDB scripts: OBJFILE%s\n"),
- ext_lang_auto_load_suffix (&extension_language_gdb));
+ suffix);
python_name_help = NULL;
#ifdef HAVE_PYTHON
+ suffix = ext_lang_auto_load_suffix (get_ext_lang_defn (EXT_LANG_PYTHON));
python_name_help
= xstrprintf (_("\
Python scripts: OBJFILE%s\n"),
- ext_lang_auto_load_suffix (&extension_language_python));
+ suffix);
+#endif
+ guile_name_help = NULL;
+#ifdef HAVE_GUILE
+ suffix = ext_lang_auto_load_suffix (get_ext_lang_defn (EXT_LANG_GUILE));
+ guile_name_help
+ = xstrprintf (_("\
+Guile scripts: OBJFILE%s\n"),
+ suffix);
#endif
scripts_directory_help
= xstrprintf (_("\
by this option.\n\
\n\
Script names:\n\
-%s%s\
+%s%s%s\
\n\
This option is ignored for the kinds of scripts \
having 'set auto-load ... off'.\n\
in the 'set auto-load safe-path'\n\
option."),
gdb_name_help,
- python_name_help ? python_name_help : "");
+ python_name_help ? python_name_help : "",
+ guile_name_help ? guile_name_help : "");
add_setshow_optional_filename_cmd ("scripts-directory", class_support,
&auto_load_dir, _("\
xfree (scripts_directory_help);
xfree (python_name_help);
xfree (gdb_name_help);
+ xfree (guile_name_help);
auto_load_safe_path = xstrdup (AUTO_LOAD_SAFE_PATH);
auto_load_safe_path_vec_update ();
struct value;
struct block;
struct gdbpy_breakpoint_object;
+struct gdbscm_breakpoint_object;
struct get_number_or_range_state;
struct thread_info;
struct bpstats;
can sometimes be NULL for enabled GDBs as not all breakpoint
types are tracked by the scripting language API. */
struct gdbpy_breakpoint_object *py_bp_object;
+
+ /* Same as py_bp_object, but for Scheme. */
+ struct gdbscm_breakpoint_object *scm_bp_object;
};
/* An instance of this type is used to represent a watchpoint. It
const char *comname = args;
c = lookup_cmd (&comname, cmdlist, "", 0, 1);
- /* c->user_commands would be NULL if it's a python command. */
+ /* c->user_commands would be NULL if it's a python/scheme command. */
if (c->class != class_user || !c->user_commands)
error (_("Not a user command."));
show_user_1 (c, "", args, gdb_stdout);
Run the ``make'' program using the rest of the line as arguments."));
set_cmd_completer (c, filename_completer);
add_cmd ("user", no_class, show_user, _("\
-Show definitions of non-python user defined commands.\n\
+Show definitions of non-python/scheme user defined commands.\n\
Argument is the name of the user defined command.\n\
With no argument, show definitions of all user defined commands."), &showlist);
add_com ("apropos", class_support, apropos_command,
add_setshow_uinteger_cmd ("max-user-call-depth", no_class,
&max_user_call_depth, _("\
-Set the max call depth for non-python user-defined commands."), _("\
-Show the max call depth for non-python user-defined commands."), NULL,
+Set the max call depth for non-python/scheme user-defined commands."), _("\
+Show the max call depth for non-python/scheme user-defined commands."), NULL,
NULL,
show_max_user_call_depth,
&setlist, &showlist);
case while_stepping_control:
case commands_control:
case python_control:
+ case guile_control:
return 1;
default:
return 0;
continue;
}
+ if (list->control_type == guile_control)
+ {
+ ui_out_field_string (uiout, NULL, "guile");
+ ui_out_text (uiout, "\n");
+ print_command_lines (uiout, *list->body_list, depth + 1);
+ if (depth)
+ ui_out_spaces (uiout, 2 * depth);
+ ui_out_field_string (uiout, NULL, "end");
+ ui_out_text (uiout, "\n");
+ list = list->next;
+ continue;
+ }
+
/* Ignore illegal command type and try next. */
list = list->next;
} /* while (list) */
}
case python_control:
+ case guile_control:
{
eval_ext_lang_from_control_command (cmd);
ret = simple_control;
here. */
*command = build_command_line (python_control, "");
}
+ else if (p_end - p == 5 && !strncmp (p, "guile", 5))
+ {
+ /* Note that we ignore the inline "guile command" form here. */
+ *command = build_command_line (guile_control, "");
+ }
else if (p_end - p == 10 && !strncmp (p, "loop_break", 10))
{
*command = (struct command_line *)
next = NULL;
val = process_next_line (read_next_line_func (), &next,
- current_cmd->control_type != python_control,
+ current_cmd->control_type != python_control
+ && current_cmd->control_type != guile_control,
validator, closure);
/* Just skip blanks and comments. */
/* Define if <sys/procfs.h> has gregset_t. */
#undef HAVE_GREGSET_T
+/* Define if Guile interpreter is being linked in. */
+#undef HAVE_GUILE
+
/* Define if you have the iconv() function. */
#undef HAVE_ICONV
CONFIG_LDFLAGS
RDYNAMIC
ALLOCA
+GUILE_LIBS
+GUILE_CPPFLAGS
+pkg_config_prog_path
PYTHON_LIBS
PYTHON_CPPFLAGS
PYTHON_CFLAGS
enable_rpath
with_libexpat_prefix
with_python
+with_guile
enable_libmcheck
with_included_regex
with_sysroot
--without-libexpat-prefix don't search for libexpat in includedir and libdir
--with-python[=PYTHON] include python support
(auto/yes/no/<python-program>)
+ --with-guile[=GUILE] include guile support
+ (auto/yes/no/<guile-version>/<pkg-config-program>)
--without-included-regex
don't use included regex; this is the default on
systems with version 2 of the GNU C library (use
+# -------------------- #
+# Check for libguile. #
+# -------------------- #
+
+
+# Extract the first word of "pkg-config", so it can be a program name with args.
+set dummy pkg-config; ac_word=$2
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5
+$as_echo_n "checking for $ac_word... " >&6; }
+if test "${ac_cv_path_pkg_config_prog_path+set}" = set; then :
+ $as_echo_n "(cached) " >&6
+else
+ case $pkg_config_prog_path in
+ [\\/]* | ?:[\\/]*)
+ ac_cv_path_pkg_config_prog_path="$pkg_config_prog_path" # Let the user override the test with a path.
+ ;;
+ *)
+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR
+for as_dir in $PATH
+do
+ IFS=$as_save_IFS
+ test -z "$as_dir" && as_dir=.
+ for ac_exec_ext in '' $ac_executable_extensions; do
+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then
+ ac_cv_path_pkg_config_prog_path="$as_dir/$ac_word$ac_exec_ext"
+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5
+ break 2
+ fi
+done
+ done
+IFS=$as_save_IFS
+
+ test -z "$ac_cv_path_pkg_config_prog_path" && ac_cv_path_pkg_config_prog_path="missing"
+ ;;
+esac
+fi
+pkg_config_prog_path=$ac_cv_path_pkg_config_prog_path
+if test -n "$pkg_config_prog_path"; then
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $pkg_config_prog_path" >&5
+$as_echo "$pkg_config_prog_path" >&6; }
+else
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
+$as_echo "no" >&6; }
+fi
+
+
+
+
+
+
+
+
+# Check whether --with-guile was given.
+if test "${with_guile+set}" = set; then :
+ withval=$with_guile;
+else
+ with_guile=auto
+fi
+
+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to use guile" >&5
+$as_echo_n "checking whether to use guile... " >&6; }
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $with_guile" >&5
+$as_echo "$with_guile" >&6; }
+
+try_guile_versions="guile-2.0"
+have_libguile=no
+case "${with_guile}" in
+no)
+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: guile support disabled; some features will be unavailable." >&5
+$as_echo "$as_me: WARNING: guile support disabled; some features will be unavailable." >&2;}
+ ;;
+auto)
+
+ pkg_config=${pkg_config_prog_path}
+ guile_version_list=${try_guile_versions}
+ flag_errors=no
+
+ if test "${pkg_config}" = "missing"; then
+ as_fn_error "pkg-config program not found" "$LINENO" 5
+ fi
+ if test ! -f "${pkg_config}"; then
+ as_fn_error "pkg-config program ${pkg_config} not found" "$LINENO" 5
+ fi
+ found_usable_guile=checking
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for usable guile from ${pkg_config}" >&5
+$as_echo_n "checking for usable guile from ${pkg_config}... " >&6; }
+ for guile_version in ${guile_version_list}; do
+ ${pkg_config} --exists ${guile_version} 2>/dev/null
+ if test $? != 0; then
+ continue
+ fi
+ new_CPPFLAGS=`${pkg_config} --cflags ${guile_version}`
+ if test $? != 0; then
+ as_fn_error "failure running pkg-config --cflags ${guile_version}" "$LINENO" 5
+ fi
+ new_LIBS=`${pkg_config} --libs ${guile_version}`
+ if test $? != 0; then
+ as_fn_error "failure running pkg-config --libs ${guile_version}" "$LINENO" 5
+ fi
+ found_usable_guile=${guile_version}
+ break
+ done
+ if test "${found_usable_guile}" = "checking"; then
+ if test "${flag_errors}" = "yes"; then
+ as_fn_error "unable to find usable guile version from \"${guile_version_list}\"" "$LINENO" 5
+ else
+ found_usable_guile=no
+ fi
+ fi
+ if test "${found_usable_guile}" != no; then
+ save_CPPFLAGS=$CPPFLAGS
+ save_LIBS=$LIBS
+ CPPFLAGS="$CPPFLAGS $new_CPPFLAGS"
+ LIBS="$LIBS $new_LIBS"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include "libguile.h"
+int
+main ()
+{
+scm_init_guile ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ have_libguile=yes
+ GUILE_CPPFLAGS=$new_CPPFLAGS
+ GUILE_LIBS=$new_LIBS
+else
+ found_usable_guile=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ CPPFLAGS=$save_CPPFLAGS
+ LIBS=$save_LIBS
+ if test "${found_usable_guile}" = no; then
+ if test "${flag_errors}" = yes; then
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error "linking guile version ${guile_version} test program failed
+See \`config.log' for more details." "$LINENO" 5; }
+ fi
+ fi
+ fi
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${found_usable_guile}" >&5
+$as_echo "${found_usable_guile}" >&6; }
+
+ ;;
+yes)
+
+ pkg_config=${pkg_config_prog_path}
+ guile_version_list=${try_guile_versions}
+ flag_errors=yes
+
+ if test "${pkg_config}" = "missing"; then
+ as_fn_error "pkg-config program not found" "$LINENO" 5
+ fi
+ if test ! -f "${pkg_config}"; then
+ as_fn_error "pkg-config program ${pkg_config} not found" "$LINENO" 5
+ fi
+ found_usable_guile=checking
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for usable guile from ${pkg_config}" >&5
+$as_echo_n "checking for usable guile from ${pkg_config}... " >&6; }
+ for guile_version in ${guile_version_list}; do
+ ${pkg_config} --exists ${guile_version} 2>/dev/null
+ if test $? != 0; then
+ continue
+ fi
+ new_CPPFLAGS=`${pkg_config} --cflags ${guile_version}`
+ if test $? != 0; then
+ as_fn_error "failure running pkg-config --cflags ${guile_version}" "$LINENO" 5
+ fi
+ new_LIBS=`${pkg_config} --libs ${guile_version}`
+ if test $? != 0; then
+ as_fn_error "failure running pkg-config --libs ${guile_version}" "$LINENO" 5
+ fi
+ found_usable_guile=${guile_version}
+ break
+ done
+ if test "${found_usable_guile}" = "checking"; then
+ if test "${flag_errors}" = "yes"; then
+ as_fn_error "unable to find usable guile version from \"${guile_version_list}\"" "$LINENO" 5
+ else
+ found_usable_guile=no
+ fi
+ fi
+ if test "${found_usable_guile}" != no; then
+ save_CPPFLAGS=$CPPFLAGS
+ save_LIBS=$LIBS
+ CPPFLAGS="$CPPFLAGS $new_CPPFLAGS"
+ LIBS="$LIBS $new_LIBS"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include "libguile.h"
+int
+main ()
+{
+scm_init_guile ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ have_libguile=yes
+ GUILE_CPPFLAGS=$new_CPPFLAGS
+ GUILE_LIBS=$new_LIBS
+else
+ found_usable_guile=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ CPPFLAGS=$save_CPPFLAGS
+ LIBS=$save_LIBS
+ if test "${found_usable_guile}" = no; then
+ if test "${flag_errors}" = yes; then
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error "linking guile version ${guile_version} test program failed
+See \`config.log' for more details." "$LINENO" 5; }
+ fi
+ fi
+ fi
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${found_usable_guile}" >&5
+$as_echo "${found_usable_guile}" >&6; }
+
+ ;;
+[\\/]* | ?:[\\/]*)
+
+ pkg_config=${with_guile}
+ guile_version_list=${try_guile_versions}
+ flag_errors=yes
+
+ if test "${pkg_config}" = "missing"; then
+ as_fn_error "pkg-config program not found" "$LINENO" 5
+ fi
+ if test ! -f "${pkg_config}"; then
+ as_fn_error "pkg-config program ${pkg_config} not found" "$LINENO" 5
+ fi
+ found_usable_guile=checking
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for usable guile from ${pkg_config}" >&5
+$as_echo_n "checking for usable guile from ${pkg_config}... " >&6; }
+ for guile_version in ${guile_version_list}; do
+ ${pkg_config} --exists ${guile_version} 2>/dev/null
+ if test $? != 0; then
+ continue
+ fi
+ new_CPPFLAGS=`${pkg_config} --cflags ${guile_version}`
+ if test $? != 0; then
+ as_fn_error "failure running pkg-config --cflags ${guile_version}" "$LINENO" 5
+ fi
+ new_LIBS=`${pkg_config} --libs ${guile_version}`
+ if test $? != 0; then
+ as_fn_error "failure running pkg-config --libs ${guile_version}" "$LINENO" 5
+ fi
+ found_usable_guile=${guile_version}
+ break
+ done
+ if test "${found_usable_guile}" = "checking"; then
+ if test "${flag_errors}" = "yes"; then
+ as_fn_error "unable to find usable guile version from \"${guile_version_list}\"" "$LINENO" 5
+ else
+ found_usable_guile=no
+ fi
+ fi
+ if test "${found_usable_guile}" != no; then
+ save_CPPFLAGS=$CPPFLAGS
+ save_LIBS=$LIBS
+ CPPFLAGS="$CPPFLAGS $new_CPPFLAGS"
+ LIBS="$LIBS $new_LIBS"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include "libguile.h"
+int
+main ()
+{
+scm_init_guile ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ have_libguile=yes
+ GUILE_CPPFLAGS=$new_CPPFLAGS
+ GUILE_LIBS=$new_LIBS
+else
+ found_usable_guile=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ CPPFLAGS=$save_CPPFLAGS
+ LIBS=$save_LIBS
+ if test "${found_usable_guile}" = no; then
+ if test "${flag_errors}" = yes; then
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error "linking guile version ${guile_version} test program failed
+See \`config.log' for more details." "$LINENO" 5; }
+ fi
+ fi
+ fi
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${found_usable_guile}" >&5
+$as_echo "${found_usable_guile}" >&6; }
+
+ ;;
+"" | */*)
+ # Disallow --with=guile="" and --with-guile=foo/bar.
+ as_fn_error "invalid value for --with-guile" "$LINENO" 5
+ ;;
+*)
+ # A space separate list of guile versions to try, in order.
+
+ pkg_config=${pkg_config_prog_path}
+ guile_version_list=${with_guile}
+ flag_errors=yes
+
+ if test "${pkg_config}" = "missing"; then
+ as_fn_error "pkg-config program not found" "$LINENO" 5
+ fi
+ if test ! -f "${pkg_config}"; then
+ as_fn_error "pkg-config program ${pkg_config} not found" "$LINENO" 5
+ fi
+ found_usable_guile=checking
+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for usable guile from ${pkg_config}" >&5
+$as_echo_n "checking for usable guile from ${pkg_config}... " >&6; }
+ for guile_version in ${guile_version_list}; do
+ ${pkg_config} --exists ${guile_version} 2>/dev/null
+ if test $? != 0; then
+ continue
+ fi
+ new_CPPFLAGS=`${pkg_config} --cflags ${guile_version}`
+ if test $? != 0; then
+ as_fn_error "failure running pkg-config --cflags ${guile_version}" "$LINENO" 5
+ fi
+ new_LIBS=`${pkg_config} --libs ${guile_version}`
+ if test $? != 0; then
+ as_fn_error "failure running pkg-config --libs ${guile_version}" "$LINENO" 5
+ fi
+ found_usable_guile=${guile_version}
+ break
+ done
+ if test "${found_usable_guile}" = "checking"; then
+ if test "${flag_errors}" = "yes"; then
+ as_fn_error "unable to find usable guile version from \"${guile_version_list}\"" "$LINENO" 5
+ else
+ found_usable_guile=no
+ fi
+ fi
+ if test "${found_usable_guile}" != no; then
+ save_CPPFLAGS=$CPPFLAGS
+ save_LIBS=$LIBS
+ CPPFLAGS="$CPPFLAGS $new_CPPFLAGS"
+ LIBS="$LIBS $new_LIBS"
+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext
+/* end confdefs.h. */
+#include "libguile.h"
+int
+main ()
+{
+scm_init_guile ();
+ ;
+ return 0;
+}
+_ACEOF
+if ac_fn_c_try_link "$LINENO"; then :
+ have_libguile=yes
+ GUILE_CPPFLAGS=$new_CPPFLAGS
+ GUILE_LIBS=$new_LIBS
+else
+ found_usable_guile=no
+fi
+rm -f core conftest.err conftest.$ac_objext \
+ conftest$ac_exeext conftest.$ac_ext
+ CPPFLAGS=$save_CPPFLAGS
+ LIBS=$save_LIBS
+ if test "${found_usable_guile}" = no; then
+ if test "${flag_errors}" = yes; then
+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5
+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}
+as_fn_error "linking guile version ${guile_version} test program failed
+See \`config.log' for more details." "$LINENO" 5; }
+ fi
+ fi
+ fi
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${found_usable_guile}" >&5
+$as_echo "${found_usable_guile}" >&6; }
+
+ ;;
+esac
+
+if test "${have_libguile}" != no; then
+
+$as_echo "#define HAVE_GUILE 1" >>confdefs.h
+
+ CONFIG_OBS="$CONFIG_OBS \$(SUBDIR_GUILE_OBS)"
+ CONFIG_DEPS="$CONFIG_DEPS \$(SUBDIR_GUILE_DEPS)"
+ CONFIG_SRCS="$CONFIG_SRCS \$(SUBDIR_GUILE_SRCS)"
+ CONFIG_INSTALL="$CONFIG_INSTALL install-guile"
+ ENABLE_CFLAGS="$ENABLE_CFLAGS \$(SUBDIR_GUILE_CFLAGS)"
+else
+ # Even if Guile support is not compiled in, we need to have these files
+ # included.
+ CONFIG_OBS="$CONFIG_OBS guile.o"
+ CONFIG_SRCS="$CONFIG_SRCS guile/guile.c"
+fi
+
+
+
# --------------------- #
# Check for libmcheck. #
# --------------------- #
AC_SUBST(PYTHON_CPPFLAGS)
AC_SUBST(PYTHON_LIBS)
+# -------------------- #
+# Check for libguile. #
+# -------------------- #
+
+dnl We check guile with pkg-config.
+
+AC_PATH_PROG(pkg_config_prog_path, pkg-config, missing)
+
+dnl Utility to simplify finding libguile.
+dnl $1 = pkg-config-program
+dnl $2 = space-separate list of guile versions to try
+dnl $3 = yes|no, indicating whether to flag errors or ignore them
+dnl $4 = the shell variable to assign the result to
+dnl If libguile is found we store "yes" here.
+
+AC_DEFUN([AC_TRY_LIBGUILE],
+[
+ pkg_config=$1
+ guile_version_list=$2
+ flag_errors=$3
+ define([have_libguile_var],$4)
+ if test "${pkg_config}" = "missing"; then
+ AC_ERROR(pkg-config program not found)
+ fi
+ if test ! -f "${pkg_config}"; then
+ AC_ERROR(pkg-config program ${pkg_config} not found)
+ fi
+ found_usable_guile=checking
+ AC_MSG_CHECKING([for usable guile from ${pkg_config}])
+ for guile_version in ${guile_version_list}; do
+ ${pkg_config} --exists ${guile_version} 2>/dev/null
+ if test $? != 0; then
+ continue
+ fi
+ dnl pkg-config says the package exists, so if we get an error now,
+ dnl that's bad.
+ new_CPPFLAGS=`${pkg_config} --cflags ${guile_version}`
+ if test $? != 0; then
+ AC_ERROR(failure running pkg-config --cflags ${guile_version})
+ fi
+ new_LIBS=`${pkg_config} --libs ${guile_version}`
+ if test $? != 0; then
+ AC_ERROR(failure running pkg-config --libs ${guile_version})
+ fi
+ dnl If we get this far, great.
+ found_usable_guile=${guile_version}
+ break
+ done
+ if test "${found_usable_guile}" = "checking"; then
+ if test "${flag_errors}" = "yes"; then
+ AC_ERROR(unable to find usable guile version from "${guile_version_list}")
+ else
+ found_usable_guile=no
+ fi
+ fi
+ dnl One final sanity check.
+ dnl The user could have said --with-guile=python-2.7.
+ if test "${found_usable_guile}" != no; then
+ save_CPPFLAGS=$CPPFLAGS
+ save_LIBS=$LIBS
+ CPPFLAGS="$CPPFLAGS $new_CPPFLAGS"
+ LIBS="$LIBS $new_LIBS"
+ AC_LINK_IFELSE(AC_LANG_PROGRAM([[#include "libguile.h"]],
+ [[scm_init_guile ();]]),
+ [have_libguile_var=yes
+ GUILE_CPPFLAGS=$new_CPPFLAGS
+ GUILE_LIBS=$new_LIBS],
+ [found_usable_guile=no])
+ CPPFLAGS=$save_CPPFLAGS
+ LIBS=$save_LIBS
+ if test "${found_usable_guile}" = no; then
+ if test "${flag_errors}" = yes; then
+ AC_MSG_FAILURE(linking guile version ${guile_version} test program failed)
+ fi
+ fi
+ fi
+ AC_MSG_RESULT([${found_usable_guile}])
+])
+
+dnl There are several different values for --with-guile:
+dnl
+dnl no - Don't include guile support.
+dnl yes - Include guile support, error if it's missing.
+dnl The pkg-config program must be in $PATH.
+dnl auto - Same as "yes", but if guile is missing from the system,
+dnl fall back to "no".
+dnl guile-version [guile-version-choice-2 ...] -
+dnl A space-separated list of guile package versions to try.
+dnl These are passed to pkg-config as-is.
+dnl E.g., guile-2.0 or guile-2.2-uninstalled
+dnl This requires making sure PKG_CONFIG_PATH is set appropriately.
+dnl /path/to/pkg-config -
+dnl Use this pkg-config program.
+dnl NOTE: This needn't be the "real" pkg-config program.
+dnl It could be a shell script. It is invoked as:
+dnl pkg-config --exists $version
+dnl pkg-config --cflags $version
+dnl pkg-config --libs $version
+dnl $version will be the default guile version (currently guile-2.0),
+dnl but the program is free to ignore this.
+
+AC_ARG_WITH(guile,
+ AS_HELP_STRING([--with-guile@<:@=GUILE@:>@], [include guile support (auto/yes/no/<guile-version>/<pkg-config-program>)]),
+ [], [with_guile=auto])
+AC_MSG_CHECKING([whether to use guile])
+AC_MSG_RESULT([$with_guile])
+
+try_guile_versions="guile-2.0"
+have_libguile=no
+case "${with_guile}" in
+no)
+ AC_MSG_WARN([guile support disabled; some features will be unavailable.])
+ ;;
+auto)
+ AC_TRY_LIBGUILE(${pkg_config_prog_path}, ${try_guile_versions}, no, have_libguile)
+ ;;
+yes)
+ AC_TRY_LIBGUILE(${pkg_config_prog_path}, ${try_guile_versions}, yes, have_libguile)
+ ;;
+[[\\/]]* | ?:[[\\/]]*)
+ AC_TRY_LIBGUILE(${with_guile}, ${try_guile_versions}, yes, have_libguile)
+ ;;
+"" | */*)
+ # Disallow --with=guile="" and --with-guile=foo/bar.
+ AC_ERROR(invalid value for --with-guile)
+ ;;
+*)
+ # A space separate list of guile versions to try, in order.
+ AC_TRY_LIBGUILE(${pkg_config_prog_path}, ${with_guile}, yes, have_libguile)
+ ;;
+esac
+
+if test "${have_libguile}" != no; then
+ AC_DEFINE(HAVE_GUILE, 1, [Define if Guile interpreter is being linked in.])
+ CONFIG_OBS="$CONFIG_OBS \$(SUBDIR_GUILE_OBS)"
+ CONFIG_DEPS="$CONFIG_DEPS \$(SUBDIR_GUILE_DEPS)"
+ CONFIG_SRCS="$CONFIG_SRCS \$(SUBDIR_GUILE_SRCS)"
+ CONFIG_INSTALL="$CONFIG_INSTALL install-guile"
+ ENABLE_CFLAGS="$ENABLE_CFLAGS \$(SUBDIR_GUILE_CFLAGS)"
+else
+ # Even if Guile support is not compiled in, we need to have these files
+ # included.
+ CONFIG_OBS="$CONFIG_OBS guile.o"
+ CONFIG_SRCS="$CONFIG_SRCS guile/guile.c"
+fi
+AC_SUBST(GUILE_CPPFLAGS)
+AC_SUBST(GUILE_LIBS)
+
# --------------------- #
# Check for libmcheck. #
# --------------------- #
srcdir = @srcdir@
SYSCALLS_SRCDIR = $(srcdir)/../syscalls
PYTHON_SRCDIR = $(srcdir)/../python/lib
+GUILE_SRCDIR = $(srcdir)/../guile/lib
SYSTEM_GDBINIT_SRCDIR = $(srcdir)/../system-gdbinit
-VPATH = $(srcdir):$(SYSCALLS_SRCDIR):$(PYTHON_SRCDIR):$(SYSTEM_GDBINIT_SRCDIR)
+VPATH = $(srcdir):$(SYSCALLS_SRCDIR):$(PYTHON_SRCDIR):$(GUILE_SRCDIR):$(SYSTEM_GDBINIT_SRCDIR)
top_srcdir = @top_srcdir@
top_builddir = @top_builddir@
gdb/function/__init__.py \
gdb/function/strfns.py
+GUILE_DIR = guile
+GUILE_INSTALL_DIR = $(DESTDIR)$(GDB_DATADIR)/$(GUILE_DIR)
+GUILE_FILES = \
+ ./gdb.scm \
+ gdb/boot.scm \
+ gdb/experimental.scm \
+ gdb/init.scm \
+ gdb/iterator.scm \
+ gdb/printing.scm \
+ gdb/types.scm
+
SYSTEM_GDBINIT_DIR = system-gdbinit
SYSTEM_GDBINIT_INSTALL_DIR = $(DESTDIR)$(GDB_DATADIR)/$(SYSTEM_GDBINIT_DIR)
SYSTEM_GDBINIT_FILES = \
"RUNTESTFLAGS=$(RUNTESTFLAGS)"
.PHONY: all
-all: stamp-syscalls stamp-python stamp-system-gdbinit
+all: stamp-syscalls stamp-python stamp-guile stamp-system-gdbinit
# For portability's sake, we need to handle systems that don't have
# symbolic links.
done \
done
+stamp-guile: Makefile $(GUILE_FILES)
+ rm -rf ./$(GUILE_DIR)
+ files='$(GUILE_FILES)' ; \
+ for file in $$files ; do \
+ dir=`echo "$$file" | sed 's,/[^/]*$$,,'` ; \
+ $(INSTALL_DIR) ./$(GUILE_DIR)/$$dir ; \
+ $(INSTALL_DATA) $(GUILE_SRCDIR)/$$file ./$(GUILE_DIR)/$$dir ; \
+ done
+ touch $@
+
+.PHONY: clean-guile
+clean-guile:
+ rm -rf $(GUILE_DIR)
+ rm -f stamp-guile
+
+.PHONY: install-guile
+install-guile:
+ files='$(GUILE_FILES)' ; \
+ for file in $$files ; do \
+ dir=`echo "$$file" | sed 's,/[^/]*$$,,'` ; \
+ $(INSTALL_DIR) $(GUILE_INSTALL_DIR)/$$dir ; \
+ $(INSTALL_DATA) ./$(GUILE_DIR)/$$file $(GUILE_INSTALL_DIR)/$$dir ; \
+ done
+
+.PHONY: uninstall-guile
+uninstall-guile:
+ files='$(GUILE_FILES)' ; \
+ for file in $$files ; do \
+ slashdir=`echo "/$$file" | sed 's,/[^/]*$$,,'` ; \
+ rm -f $(GUILE_INSTALL_DIR)/$$file ; \
+ while test "x$$file" != "x$$slashdir" ; do \
+ rmdir 2>/dev/null "$(GUILE_INSTALL_DIR)$$slashdir" ; \
+ file="$$slashdir" ; \
+ slashdir=`echo "$$file" | sed 's,/[^/]*$$,,'` ; \
+ done \
+ done
+
stamp-system-gdbinit: Makefile $(SYSTEM_GDBINIT_FILES)
rm -rf ./$(SYSTEM_GDBINIT_DIR)
mkdir ./$(SYSTEM_GDBINIT_DIR)
@$(MAKE) $(FLAGS_TO_PASS) install-only
.PHONY: install-only
-install-only: install-syscalls install-python install-system-gdbinit
+install-only: install-syscalls install-python install-guile \
+ install-system-gdbinit
.PHONY: uninstall
-uninstall: uninstall-syscalls uninstall-python uninstall-system-gdbinit
+uninstall: uninstall-syscalls uninstall-python uninstall-guile \
+ uninstall-system-gdbinit
.PHONY: clean
-clean: clean-syscalls clean-python clean-system-gdbinit
+clean: clean-syscalls clean-python clean-guile clean-system-gdbinit
.PHONY: maintainer-clean realclean distclean
maintainer-clean realclean distclean: clean
if_control,
commands_control,
python_control,
+ guile_control,
while_stepping_control,
invalid_control
};
return 0;
}
-static struct disassemble_info
+struct disassemble_info
gdb_disassemble_info (struct gdbarch *gdbarch, struct ui_file *file)
{
struct disassemble_info di;
#ifndef DISASM_H
#define DISASM_H
+#include "dis-asm.h"
+
#define DISASSEMBLY_SOURCE (0x1 << 0)
#define DISASSEMBLY_RAW_INSN (0x1 << 1)
#define DISASSEMBLY_OMIT_FNAME (0x1 << 2)
#define DISASSEMBLY_FILENAME (0x1 << 3)
#define DISASSEMBLY_OMIT_PC (0x1 << 4)
+struct gdbarch;
struct ui_out;
struct ui_file;
+/* Return a filled in disassemble_info object for use by gdb. */
+
+extern struct disassemble_info gdb_disassemble_info (struct gdbarch *gdbarch,
+ struct ui_file *file);
+
extern void gdb_disassembly (struct gdbarch *gdbarch, struct ui_out *uiout,
char *file_string, int flags, int how_many,
CORE_ADDR low, CORE_ADDR high);
+2014-02-10 Doug Evans <xdje42@gmail.com>
+
+ * Makefile.in (GDB_DOC_FILES): Add guile.texi.
+ * gdb.texinfo (Auto-loading): Add set/show auto-load guile-scripts.
+ (Extending GDB): New menu entries Guile, Multiple Extension Languages.
+ (Guile docs): Include guile.texi.
+ (objfile-gdbdotext file): Add objfile-gdb.scm.
+ (dotdebug_gdb_scripts section): Mention Guile scripts.
+ (Multiple Extension Languages): New node.
+ * guile.texi: New file.
+
2014-01-28 Joel Brobecker <brobecker@adacore.com>
* gdb.texinfo (Ada Glitches): Document the new "maint ada set/show
GDBvn.texi
GDB_DOC_FILES = \
$(srcdir)/gdb.texinfo \
+ $(srcdir)/guile.texi \
$(GDB_DOC_SOURCE_INCLUDES) \
$(GDB_DOC_BUILD_INCLUDES)
@tab Show setting of @value{GDBN} Python scripts.
@item @xref{info auto-load python-scripts}.
@tab Show state of @value{GDBN} Python scripts.
+@item @xref{set auto-load guile-scripts}.
+@tab Control for @value{GDBN} Guile scripts.
+@item @xref{show auto-load guile-scripts}.
+@tab Show setting of @value{GDBN} Guile scripts.
+@item @xref{info auto-load guile-scripts}.
+@tab Show state of @value{GDBN} Guile scripts.
@item @xref{set auto-load scripts-directory}.
@tab Control for @value{GDBN} auto-loaded scripts location.
@item @xref{show auto-load scripts-directory}.
@menu
* Sequences:: Canned Sequences of @value{GDBN} Commands
* Python:: Extending @value{GDBN} using Python
+* Guile:: Extending @value{GDBN} using Guile
* Auto-loading extensions:: Automatically loading extensions
+* Multiple Extension Languages:: Working with multiple extension languages
* Aliases:: Creating new spellings of existing commands
@end menu
@end smallexample
@end table
+@c Guile docs live in a separate file.
+@include guile.texi
+
@node Auto-loading extensions
@section Auto-loading extensions
@cindex auto-loading extensions
GDB's own command language
@item @file{@var{objfile}-gdb.py}
Python
+@item @file{@var{objfile}-gdb.scm}
+Guile
@end table
@var{script-name} is formed by ensuring that the file name of @var{objfile}
@end example
@noindent
+For Guile scripts, replace @code{.byte 1} with @code{.byte 3}.
Then one can reference the macro in a header or source file like this:
@example
top of the source tree to the source search path.
@end itemize
+@node Multiple Extension Languages
+@section Multiple Extension Languages
+
+The Guile and Python extension languages do not share any state,
+and generally do not interfere with each other.
+There are some things to be aware of, however.
+
+@subsection Python comes first
+
+Python was @value{GDBN}'s first extension language, and to avoid breaking
+existing behaviour Python comes first. This is generally solved by the
+``first one wins'' principle. @value{GDBN} maintains a list of enabled
+extension languages, and when it makes a call to an extension language,
+(say to pretty-print a value), it tries each in turn until an extension
+language indicates it has performed the request (e.g., has returned the
+pretty-printed form of a value).
+This extends to errors while performing such requests: If an error happens
+while, for example, trying to pretty-print an object then the error is
+reported and any following extension languages are not tried.
+
@node Aliases
@section Creating new spellings of existing commands
@cindex aliases for commands
--- /dev/null
+@c Copyright (C) 2008-2014 Free Software Foundation, Inc.
+@c Permission is granted to copy, distribute and/or modify this document
+@c under the terms of the GNU Free Documentation License, Version 1.3 or
+@c any later version published by the Free Software Foundation; with the
+@c Invariant Sections being ``Free Software'' and ``Free Software Needs
+@c Free Documentation'', with the Front-Cover Texts being ``A GNU Manual,''
+@c and with the Back-Cover Texts as in (a) below.
+@c
+@c (a) The FSF's Back-Cover Text is: ``You are free to copy and modify
+@c this GNU Manual. Buying copies from GNU Press supports the FSF in
+@c developing GNU and promoting software freedom.''
+
+@node Guile
+@section Extending @value{GDBN} using Guile
+@cindex guile scripting
+@cindex scripting with guile
+
+You can extend @value{GDBN} using the @uref{http://www.gnu.org/software/guile/,
+Guile implementation of the Scheme programming language}.
+This feature is available only if @value{GDBN} was configured using
+@option{--with-guile}.
+
+@menu
+* Guile Introduction:: Introduction to Guile scripting in @value{GDBN}
+* Guile Commands:: Accessing Guile from @value{GDBN}
+* Guile API:: Accessing @value{GDBN} from Guile
+* Guile Auto-loading:: Automatically loading Guile code
+* Guile Modules:: Guile modules provided by @value{GDBN}
+@end menu
+
+@node Guile Introduction
+@subsection Guile Introduction
+
+Guile is an implementation of the Scheme programming language
+and is the GNU project's official extension language.
+
+Guile support in @value{GDBN} follows the Python support in @value{GDBN}
+reasonably closely, so concepts there should carry over.
+However, some things are done differently where it makes sense.
+
+@value{GDBN} requires Guile version 2.0 or greater.
+Older versions are not supported.
+
+@cindex guile scripts directory
+Guile scripts used by @value{GDBN} should be installed in
+@file{@var{data-directory}/guile}, where @var{data-directory} is
+the data directory as determined at @value{GDBN} startup (@pxref{Data Files}).
+This directory, known as the @dfn{guile directory},
+is automatically added to the Guile Search Path in order to allow
+the Guile interpreter to locate all scripts installed at this location.
+
+@node Guile Commands
+@subsection Guile Commands
+@cindex guile commands
+@cindex commands to access guile
+
+@value{GDBN} provides two commands for accessing the Guile interpreter:
+
+@table @code
+@kindex guile-repl
+@kindex gr
+@item guile-repl
+@itemx gr
+The @code{guile-repl} command can be used to start an interactive
+Guile prompt or @dfn{repl}. To return to @value{GDBN},
+type @kbd{,q} or the @code{EOF} character (e.g., @kbd{Ctrl-D} on
+an empty prompt). These commands do not take any arguments.
+
+@kindex guile
+@kindex gu
+@item guile @r{[}@var{scheme-expression}@r{]}
+@itemx gu @r{[}@var{scheme-expression}@r{]}
+The @code{guile} command can be used to evaluate a Scheme expression.
+
+If given an argument, @value{GDBN} will pass the argument to the Guile
+interpreter for evaluation.
+
+@smallexample
+(@value{GDBP}) guile (display (+ 20 3)) (newline)
+23
+@end smallexample
+
+The result of the Scheme expression is displayed using normal Guile rules.
+
+@smallexample
+(@value{GDBP}) guile (+ 20 3)
+23
+@end smallexample
+
+If you do not provide an argument to @code{guile}, it will act as a
+multi-line command, like @code{define}. In this case, the Guile
+script is made up of subsequent command lines, given after the
+@code{guile} command. This command list is terminated using a line
+containing @code{end}. For example:
+
+@smallexample
+(@value{GDBP}) guile
+>(display 23)
+>(newline)
+>end
+23
+@end smallexample
+@end table
+
+It is also possible to execute a Guile script from the @value{GDBN}
+interpreter:
+
+@table @code
+@item source @file{script-name}
+The script name must end with @samp{.scm} and @value{GDBN} must be configured
+to recognize the script language based on filename extension using
+the @code{script-extension} setting. @xref{Extending GDB, ,Extending GDB}.
+
+@item guile (load "script-name")
+This method uses the @code{load} Guile function.
+It takes a string argument that is the name of the script to load.
+See the Guile documentation for a description of this function.
+(@pxref{Loading,,, guile, GNU Guile Reference Manual}).
+@end table
+
+@node Guile API
+@subsection Guile API
+@cindex guile api
+@cindex programming in guile
+
+You can get quick online help for @value{GDBN}'s Guile API by issuing
+the command @w{@kbd{help guile}}, or by issuing the command @kbd{,help}
+from an interactive Guile session. Furthermore, most Guile procedures
+provided by @value{GDBN} have doc strings which can be obtained with
+@kbd{,describe @var{procedure-name}} or @kbd{,d @var{procedure-name}}
+from the Guile interactive prompt.
+
+@menu
+* Basic Guile:: Basic Guile Functions
+* Guile Configuration:: Guile configuration variables
+* GDB Scheme Data Types:: Scheme representations of GDB objects
+* Guile Exception Handling:: How Guile exceptions are translated
+* Values From Inferior In Guile:: Guile representation of values
+* Arithmetic In Guile:: Arithmetic in Guile
+* Types In Guile:: Guile representation of types
+* 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
+* Objfiles In Guile:: Object files in Guile
+* Frames In Guile:: Accessing inferior stack frames from Guile
+* Blocks In Guile:: Accessing blocks from Guile
+* Symbols In Guile:: Guile representation of symbols
+* Symbol Tables In Guile:: Guile representation of symbol tables
+* Breakpoints In Guile:: Manipulating breakpoints using Guile
+* Lazy Strings In Guile:: Guile representation of lazy strings
+* Architectures In Guile:: Guile representation of architectures
+* Disassembly In Guile:: Disassembling instructions from Guile
+* I/O Ports in Guile:: GDB I/O ports
+* Memory Ports in Guile:: Accessing memory through ports and bytevectors
+* Iterators In Guile:: Basic iterator support
+@end menu
+
+@node Basic Guile
+@subsubsection Basic Guile
+
+@cindex guile stdout
+@cindex guile pagination
+At startup, @value{GDBN} overrides Guile's @code{current-output-port} and
+@code{current-error-port} to print using @value{GDBN}'s output-paging streams.
+A Guile program which outputs to one of these streams may have its
+output interrupted by the user (@pxref{Screen Size}). In this
+situation, a Guile @code{signal} exception is thrown with value @code{SIGINT}.
+
+Guile's history mechanism uses the same naming as @value{GDBN}'s,
+namely the user of dollar-variables (e.g., $1, $2, etc.).
+The results of evaluations in Guile and in GDB are counted separately,
+@code{$1} in Guile is not the same value as @code{$1} in @value{GDBN}.
+
+@value{GDBN} is not thread-safe. If your Guile program uses multiple
+threads, you must be careful to only call @value{GDBN}-specific
+functions in the @value{GDBN} thread.
+
+Some care must be taken when writing Guile code to run in
+@value{GDBN}. Two things are worth noting in particular:
+
+@itemize @bullet
+@item
+@value{GDBN} installs handlers for @code{SIGCHLD} and @code{SIGINT}.
+Guile code must not override these, or even change the options using
+@code{sigaction}. If your program changes the handling of these
+signals, @value{GDBN} will most likely stop working correctly. Note
+that it is unfortunately common for GUI toolkits to install a
+@code{SIGCHLD} handler.
+
+@item
+@value{GDBN} takes care to mark its internal file descriptors as
+close-on-exec. However, this cannot be done in a thread-safe way on
+all platforms. Your Guile programs should be aware of this and
+should both create new file descriptors with the close-on-exec flag
+set and arrange to close unneeded file descriptors before starting a
+child process.
+@end itemize
+
+@cindex guile gdb module
+@value{GDBN} introduces a new Guile module, named @code{gdb}. All
+methods and classes added by @value{GDBN} are placed in this module.
+@value{GDBN} does not automatically @code{import} the @code{gdb} module,
+scripts must do this themselves. There are various options for how to
+import a module, so @value{GDBN} leaves the choice of how the @code{gdb}
+module is imported to the user.
+To simplify interactive use, it is recommended to add one of the following
+to your ~/.gdbinit.
+
+@smallexample
+guile (use-modules (gdb))
+@end smallexample
+
+@smallexample
+guile (use-modules ((gdb) #:renamer (symbol-prefix-proc 'gdb:)))
+@end smallexample
+
+Which one to choose depends on your preference.
+The second one adds @code{gdb:} as a prefix to all module functions
+and variables.
+
+The rest of this manual assumes the @code{gdb} module has been imported
+without any prefix. See the Guile documentation for @code{use-modules}
+for more information
+(@pxref{Using Guile Modules,,, guile, GNU Guile Reference Manual}).
+
+Example:
+
+@smallexample
+(gdb) guile (value-type (make-value 1))
+ERROR: Unbound variable: value-type
+Error while executing Scheme code.
+(gdb) guile (use-modules (gdb))
+(gdb) guile (value-type (make-value 1))
+int
+(gdb)
+@end smallexample
+
+The @code{(gdb)} module provides these basic Guile functions.
+
+@c TODO: line length
+@deffn {Scheme Procedure} execute command @r{[}#:from-tty boolean@r{]}@r{[}#:to-string boolean@r{]}
+Evaluate @var{command}, a string, as a @value{GDBN} CLI command.
+If a @value{GDBN} exception happens while @var{command} runs, it is
+translated as described in
+@ref{Guile Exception Handling,,Guile Exception Handling}.
+
+@var{from-tty} specifies whether @value{GDBN} ought to consider this
+command as having originated from the user invoking it interactively.
+It must be a boolean value. If omitted, it defaults to @code{#f}.
+
+By default, any output produced by @var{command} is sent to
+@value{GDBN}'s standard output (and to the log output if logging is
+turned on). If the @var{to-string} parameter is
+@code{#t}, then output will be collected by @code{gdb.execute} and
+returned as a string. The default is @code{#f}, in which case the
+return value is unspecified. If @var{to-string} is @code{#t}, the
+@value{GDBN} virtual terminal will be temporarily set to unlimited width
+and height, and its pagination will be disabled; @pxref{Screen Size}.
+@end deffn
+
+@deffn {Scheme Procedure} history-ref number
+Return a value from @value{GDBN}'s value history (@pxref{Value
+History}). @var{number} indicates which history element to return.
+If @var{number} is negative, then @value{GDBN} will take its absolute value
+and count backward from the last element (i.e., the most recent element) to
+find the value to return. If @var{number} is zero, then @value{GDBN} will
+return the most recent element. If the element specified by @var{number}
+doesn't exist in the value history, a @code{gdb:error} exception will be
+raised.
+
+If no exception is raised, the return value is always an instance of
+@code{<gdb:value>} (@pxref{Values From Inferior In Guile}).
+
+@emph{Note:} @value{GDBN}'s value history is independent of Guile's.
+@code{$1} in @value{GDBN}'s value history contains the result of evaluating
+an expression from @value{GDBN}'s command line and @code{$1} from Guile's
+history contains the result of evaluating an expression from Guile's
+command line.
+@end deffn
+
+@deffn {Scheme Procedure} parse-and-eval expression
+Parse @var{expression} as an expression in the current language,
+evaluate it, and return the result as a @code{<gdb:value>}.
+@var{expression} must be a string.
+
+This function is useful when computing values.
+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
+
+@value{GDBN} provides these Scheme functions to access various configuration
+parameters.
+
+@deffn {Scheme Procedure} data-directory
+Return a string containing @value{GDBN}'s data directory.
+This directory contains @value{GDBN}'s ancillary files, including
+the Guile modules provided by @value{GDBN}.
+@end deffn
+
+@deffn {Scheme Procedure} gdb-version
+Return a string containing the @value{GDBN} version.
+@end deffn
+
+@deffn {Scheme Procedure} host-config
+Return a string containing the host configuration.
+This is the string passed to @code{--host} when @value{GDBN} was configured.
+@end deffn
+
+@deffn {Scheme Procedure} target-config
+Return a string containing the target configuration.
+This is the string passed to @code{--target} when @value{GDBN} was configured.
+@end deffn
+
+@node GDB Scheme Data Types
+@subsubsection GDB Scheme Data Types
+@cindex gdb smobs
+
+@value{GDBN} uses Guile's @dfn{smob} (small object)
+data type for all @value{GDBN} objects
+(@pxref{Defining New Types (Smobs),,, guile, GNU Guile Reference Manual}).
+The smobs that @value{GDBN} provides are called @dfn{gsmobs}.
+
+@deffn {Scheme Procedure} gsmob-kind gsmob
+Return the kind of the gsmob, e.g., @code{<gdb:breakpoint>},
+as a symbol.
+@end deffn
+
+Every @code{gsmob} provides a common set of functions for extending
+them in simple ways. Each @code{gsmob} has a list of properties,
+initially empty. These properties are akin to Guile's object properties,
+but are stored with the @code{gsmob}
+(@pxref{Object Properties,,, guile, GNU Guile Reference Manual}).
+Property names can be any @code{eq?}-able value, but it is recommended
+that they be symbols.
+
+@deffn {Scheme Procedure} set-gsmob-property! gsmob property-name value
+Set the value of property @code{property-name} to value @code{value}.
+The result is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} gsmob-property gsmob property-name
+Return the value of property @code{property-name}.
+If the property isn't present then @code{#f} is returned.
+@end deffn
+
+@deffn {Scheme Procedure} gsmob-has-property? gsmob property-name
+Return @code{#t} if @code{gsmob} has property @code{property-name}.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} gsmob-properties gsmob
+Return an unsorted list of names of properties.
+@end deffn
+
+@value{GDBN} defines the following Scheme smobs:
+
+@table @code
+@item <gdb:arch>
+@xref{Architectures In Guile}.
+
+@item <gdb:block>
+@xref{Blocks In Guile}.
+
+@item <gdb:block-symbols-iterator>
+@xref{Blocks In Guile}.
+
+@item <gdb:breakpoint>
+@xref{Breakpoints In Guile}.
+
+@item <gdb:exception>
+@xref{Guile Exception Handling}.
+
+@item <gdb:frame>
+@xref{Frames In Guile}.
+
+@item <gdb:iterator>
+@xref{Iterators In Guile}.
+
+@item <gdb:lazy-string>
+@xref{Lazy Strings In Guile}.
+
+@item <gdb:objfile>
+@xref{Objfiles In Guile}.
+
+@item <gdb:pretty-printer>
+@xref{Guile Pretty Printing API}.
+
+@item <gdb:pretty-printer-worker>
+@xref{Guile Pretty Printing API}.
+
+@item <gdb:symbol>
+@xref{Symbols In Guile}.
+
+@item <gdb:symtab>
+@xref{Symbol Tables In Guile}.
+
+@item <gdb:sal>
+@xref{Symbol Tables In Guile}.
+
+@item <gdb:type>
+@xref{Types In Guile}.
+
+@item <gdb:field>
+@xref{Types In Guile}.
+
+@item <gdb:value>
+@xref{Values From Inferior In Guile}.
+@end table
+
+The following gsmobs are managed internally so that the Scheme function
+@code{eq?} may be applied to them.
+
+@table @code
+@item <gdb:arch>
+@item <gdb:block>
+@item <gdb:breakpoint>
+@item <gdb:frame>
+@item <gdb:objfile>
+@item <gdb:symbol>
+@item <gdb:symtab>
+@item <gdb:type>
+@end table
+
+@node Guile Exception Handling
+@subsubsection Guile Exception Handling
+@cindex guile exceptions
+@cindex exceptions, guile
+@kindex set guile print-stack
+
+When executing the @code{guile} command, Guile exceptions
+uncaught within the Guile code are translated to calls to the
+@value{GDBN} error-reporting mechanism. If the command that called
+@code{guile} does not handle the error, @value{GDBN} will
+terminate it and report the error according to the setting of
+the @code{guile print-stack} parameter.
+
+The @code{guile print-stack} parameter has three settings:
+
+@table @code
+@item none
+Nothing is printed.
+
+@item message
+An error message is printed containing the Guile exception name,
+the associated value, and the Guile call stack backtrace at the
+point where the exception was raised. Example:
+
+@smallexample
+(@value{GDBP}) guile (display foo)
+ERROR: In procedure memoize-variable-access!:
+ERROR: Unbound variable: foo
+Error while executing Scheme code.
+@end smallexample
+
+@item full
+In addition to an error message a full backtrace is printed.
+
+@smallexample
+(@value{GDBP}) set guile print-stack full
+(@value{GDBP}) guile (display foo)
+Guile Backtrace:
+In ice-9/boot-9.scm:
+ 157: 10 [catch #t #<catch-closure 2c76e20> ...]
+In unknown file:
+ ?: 9 [apply-smob/1 #<catch-closure 2c76e20>]
+In ice-9/boot-9.scm:
+ 157: 8 [catch #t #<catch-closure 2c76d20> ...]
+In unknown file:
+ ?: 7 [apply-smob/1 #<catch-closure 2c76d20>]
+ ?: 6 [call-with-input-string "(display foo)" ...]
+In ice-9/boot-9.scm:
+2320: 5 [save-module-excursion #<procedure 2c2dc30 ... ()>]
+In ice-9/eval-string.scm:
+ 44: 4 [read-and-eval #<input: string 27cb410> #:lang ...]
+ 37: 3 [lp (display foo)]
+In ice-9/eval.scm:
+ 387: 2 [eval # ()]
+ 393: 1 [eval #<memoized foo> ()]
+In unknown file:
+ ?: 0 [memoize-variable-access! #<memoized foo> ...]
+
+ERROR: In procedure memoize-variable-access!:
+ERROR: Unbound variable: foo
+Error while executing Scheme code.
+@end smallexample
+@end table
+
+@value{GDBN} errors that happen in @value{GDBN} commands invoked by
+Guile code are converted to Guile exceptions. The type of the
+Guile exception depends on the error.
+
+Guile procedures provided by @value{GDBN} can throw the standard
+Guile exceptions like @code{wrong-type-arg} and @code{out-of-range}.
+
+User interrupt (via @kbd{C-c} or by typing @kbd{q} at a pagination
+prompt) is translated to a Guile @code{signal} exception with value
+@code{SIGINT}.
+
+@value{GDBN} Guile procedures can also throw these exceptions:
+
+@vtable @code
+@item gdb:error
+This exception is a catch-all for errors generated from within @value{GDBN}.
+
+@item gdb:invalid-object
+This exception is thrown when accessing Guile objects that wrap underlying
+@value{GDBN} objects have become invalid. For example, a
+@code{<gdb:breakpoint>} object becomes invalid if the user deletes it
+from the command line. The object still exists in Guile, but the
+object it represents is gone. Further operations on this breakpoint
+will throw this exception.
+
+@item gdb:memory-error
+This exception is thrown when an operation tried to access invalid
+memory in the inferior.
+
+@item gdb:pp-type-error
+This exception is thrown when a Guile pretty-printer passes a bad object
+to @value{GDBN}.
+@end vtable
+
+The following exception-related procedures are provided by the
+@code{(gdb)} module.
+
+@deffn {Scheme Procedure} make-exception key args
+Return a @code{<gdb:exception>} object.
+@var{key} and @var{args} are the standard Guile parameters of an exception.
+See the Guile documentation for more information
+(@pxref{Exceptions,,, guile, GNU Guile Reference Manual}).
+@end deffn
+
+@deffn {Scheme Procedure} exception? object
+Return @code{#t} if @var{object} is a @code{<gdb:exception>} object.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} exception-key exception
+Return the @var{args} field of a @code{<gdb:exception>} object.
+@end deffn
+
+@deffn {Scheme Procedure} exception-args exception
+Return the @var{args} field of a @code{<gdb:exception>} object.
+@end deffn
+
+@node Values From Inferior In Guile
+@subsubsection Values From Inferior In Guile
+@cindex values from inferior, in guile
+@cindex guile, working with values from inferior
+
+@tindex @code{<gdb:value>}
+@value{GDBN} provides values it obtains from the inferior program in
+an object of type @code{<gdb:value>}. @value{GDBN} uses this object
+for its internal bookkeeping of the inferior's values, and for
+fetching values when necessary.
+
+@value{GDBN} does not memoize @code{<gdb:value>} objects.
+@code{make-value} always returns a fresh object.
+
+@smallexample
+(gdb) guile (eq? (make-value 1) (make-value 1))
+$1 = #f
+(gdb) guile (equal? (make-value 1) (make-value 1))
+$1 = #t
+@end smallexample
+
+A @code{<gdb:value>} that represents a function can be executed via
+inferior function call with @code{value-call}.
+Any arguments provided to the call must match the function's prototype,
+and must be provided in the order specified by that prototype.
+
+For example, @code{some-val} is a @code{<gdb:value>} instance
+representing a function that takes two integers as arguments. To
+execute this function, call it like so:
+
+@smallexample
+(define result (value-call some-val 10 20))
+@end smallexample
+
+Any values returned from a function call are @code{<gdb:value>} objects.
+
+Note: Unlike Python scripting in @value{GDBN},
+inferior values that are simple scalars cannot be used directly in
+Scheme expressions that are valid for the value's data type.
+For example, @code{(+ (parse-and-eval "int_variable") 2)} does not work.
+And inferior values that are structures or instances of some class cannot
+be accessed using any special syntax, instead @code{value-field} must be used.
+
+The following value-related procedures are provided by the
+@code{(gdb)} module.
+
+@deffn {Scheme Procedure} value? object
+Return @code{#t} if @var{object} is a @code{<gdb:value>} object.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} make-value value @r{[}#:type type@r{]}
+Many Scheme values can be converted directly to a @code{<gdb:value>}
+with this procedure. If @var{type} is specified, the result is a value
+of this type, and if @var{value} can't be represented with this type
+an exception is thrown. Otherwise the type of the result is determined from
+@var{value} as described below.
+
+@xref{Architectures In Guile}, for a list of the builtin
+types for an architecture.
+
+Here's how Scheme values are converted when @var{type} argument to
+@code{make-value} is not specified:
+
+@table @asis
+@item Scheme boolean
+A Scheme boolean is converted the boolean type for the current language.
+
+@item Scheme integer
+A Scheme integer is converted to the first of a C @code{int},
+@code{unsigned int}, @code{long}, @code{unsigned long},
+@code{long long} or @code{unsigned long long} type
+for the current architecture that can represent the value.
+
+If the Scheme integer cannot be represented as a target integer
+an @code{out-of-range} exception is thrown.
+
+@item Scheme real
+A Scheme real is converted to the C @code{double} type for the
+current architecture.
+
+@item Scheme string
+A Scheme string is converted to a string in the current target
+language using the current target encoding.
+Characters that cannot be represented in the current target encoding
+are replaced with the corresponding escape sequence. This is Guile's
+@code{SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE} conversion strategy
+(@pxref{Strings,,, guile, GNU Guile Reference Manual}).
+
+Passing @var{type} is not supported in this case,
+if it is provided a @code{wrong-type-arg} exception is thrown.
+
+@item @code{<gdb:lazy-string>}
+If @var{value} is a @code{<gdb:lazy-string>} object (@pxref{Lazy Strings In
+Guile}), then the @code{lazy-string->value} procedure is called, and
+its result is used.
+
+Passing @var{type} is not supported in this case,
+if it is provided a @code{wrong-type-arg} exception is thrown.
+
+@item Scheme bytevector
+If @var{value} is a Scheme bytevector and @var{type} is provided,
+@var{value} must be the same size, in bytes, of values of type @var{type},
+and the result is essentially created by using @code{memcpy}.
+
+If @var{value} is a Scheme bytevector and @var{type} is not provided,
+the result is an array of type @code{uint8} of the same length.
+@end table
+@end deffn
+
+@cindex optimized out value in guile
+@deffn {Scheme Procedure} value-optimized-out? value
+Return @code{#t} if the compiler optimized out @var{value},
+thus it is not available for fetching from the inferior.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} value-address value
+If @var{value} is addressable, returns a
+@code{<gdb:value>} object representing the address.
+Otherwise, @code{#f} is returned.
+@end deffn
+
+@deffn {Scheme Procedure} value-type value
+Return the type of @var{value} as a @code{<gdb:type>} object
+(@pxref{Types In Guile}).
+@end deffn
+
+@deffn {Scheme Procedure} value-dynamic-type value
+Return the dynamic type of @var{value}. This uses C@t{++} run-time
+type information (@acronym{RTTI}) to determine the dynamic type of the
+value. If the value is of class type, it will return the class in
+which the value is embedded, if any. If the value is of pointer or
+reference to a class type, it will compute the dynamic type of the
+referenced object, and return a pointer or reference to that type,
+respectively. In all other cases, it will return the value's static
+type.
+
+Note that this feature will only work when debugging a C@t{++} program
+that includes @acronym{RTTI} for the object in question. Otherwise,
+it will just return the static type of the value as in @kbd{ptype foo}.
+@xref{Symbols, ptype}.
+@end deffn
+
+@deffn {Scheme Procedure} value-cast value type
+Return a new instance of @code{<gdb:value>} that is the result of
+casting @var{value} to the type described by @var{type}, which must
+be a @code{<gdb:type>} object. If the cast cannot be performed for some
+reason, this method throws an exception.
+@end deffn
+
+@deffn {Scheme Procedure} value-dynamic-cast value type
+Like @code{value-cast}, but works as if the C@t{++} @code{dynamic_cast}
+operator were used. Consult a C@t{++} reference for details.
+@end deffn
+
+@deffn {Scheme Procedure} value-reinterpret-cast value type
+Like @code{value-cast}, but works as if the C@t{++} @code{reinterpret_cast}
+operator were used. Consult a C@t{++} reference for details.
+@end deffn
+
+@deffn {Scheme Procedure} value-dereference value
+For pointer data types, this method returns a new @code{<gdb:value>} object
+whose contents is the object pointed to by @var{value}. For example, if
+@code{foo} is a C pointer to an @code{int}, declared in your C program as
+
+@smallexample
+int *foo;
+@end smallexample
+
+@noindent
+then you can use the corresponding @code{<gdb:value>} to access what
+@code{foo} points to like this:
+
+@smallexample
+(define bar (value-dereference foo))
+@end smallexample
+
+The result @code{bar} will be a @code{<gdb:value>} object holding the
+value pointed to by @code{foo}.
+
+A similar function @code{value-referenced-value} exists which also
+returns @code{<gdb:value>} objects corresonding to the values pointed to
+by pointer values (and additionally, values referenced by reference
+values). However, the behavior of @code{value-dereference}
+differs from @code{value-referenced-value} by the fact that the
+behavior of @code{value-dereference} is identical to applying the C
+unary operator @code{*} on a given value. For example, consider a
+reference to a pointer @code{ptrref}, declared in your C@t{++} program
+as
+
+@smallexample
+typedef int *intptr;
+...
+int val = 10;
+intptr ptr = &val;
+intptr &ptrref = ptr;
+@end smallexample
+
+Though @code{ptrref} is a reference value, one can apply the method
+@code{value-dereference} to the @code{<gdb:value>} object corresponding
+to it and obtain a @code{<gdb:value>} which is identical to that
+corresponding to @code{val}. However, if you apply the method
+@code{value-referenced-value}, the result would be a @code{<gdb:value>}
+object identical to that corresponding to @code{ptr}.
+
+@smallexample
+(define scm-ptrref (parse-and-eval "ptrref"))
+(define scm-val (value-dereference scm-ptrref))
+(define scm-ptr (value-referenced-value scm-ptrref))
+@end smallexample
+
+The @code{<gdb:value>} object @code{scm-val} is identical to that
+corresponding to @code{val}, and @code{scm-ptr} is identical to that
+corresponding to @code{ptr}. In general, @code{value-dereference} can
+be applied whenever the C unary operator @code{*} can be applied
+to the corresponding C value. For those cases where applying both
+@code{value-dereference} and @code{value-referenced-value} is allowed,
+the results obtained need not be identical (as we have seen in the above
+example). The results are however identical when applied on
+@code{<gdb:value>} objects corresponding to pointers (@code{<gdb:value>}
+objects with type code @code{TYPE_CODE_PTR}) in a C/C@t{++} program.
+@end deffn
+
+@deffn {Scheme Procedure} value-referenced-value value
+For pointer or reference data types, this method returns a new
+@code{<gdb:value>} object corresponding to the value referenced by the
+pointer/reference value. For pointer data types,
+@code{value-dereference} and @code{value-referenced-value} produce
+identical results. The difference between these methods is that
+@code{value-dereference} cannot get the values referenced by reference
+values. For example, consider a reference to an @code{int}, declared
+in your C@t{++} program as
+
+@smallexample
+int val = 10;
+int &ref = val;
+@end smallexample
+
+@noindent
+then applying @code{value-dereference} to the @code{<gdb:value>} object
+corresponding to @code{ref} will result in an error, while applying
+@code{value-referenced-value} will result in a @code{<gdb:value>} object
+identical to that corresponding to @code{val}.
+
+@smallexample
+(define scm-ref (parse-and-eval "ref"))
+(define err-ref (value-dereference scm-ref)) ;; error
+(define scm-val (value-referenced-value scm-ref)) ;; ok
+@end smallexample
+
+The @code{<gdb:value>} object @code{scm-val} is identical to that
+corresponding to @code{val}.
+@end deffn
+
+@deffn {Scheme Procedure} value-field value field-name
+Return field @var{field-name} from @code{<gdb:value>} object @var{value}.
+@end deffn
+
+@deffn {Scheme Procedure} value-subscript value index
+Return the value of array @var{value} at index @var{index}.
+@var{value} must be a subscriptable @code{<gdb:value>} object.
+@end deffn
+
+@deffn {Scheme Procedure} value-call value arg-list
+Perform an inferior function call, taking @var{value} as a pointer
+to the function to call.
+Each element of list @var{arg-list} must be a <gdb:value> object or an object
+that can be converted to a value.
+The result is the value returned by the function.
+@end deffn
+
+@deffn {Scheme Procedure} value->bool value
+Return the Scheme boolean representing @code{<gdb:value>} @var{value}.
+The value must be ``integer like''. Pointers are ok.
+@end deffn
+
+@deffn {Scheme Procedure} value->integer
+Return the Scheme integer representing @code{<gdb:value>} @var{value}.
+The value must be ``integer like''. Pointers are ok.
+@end deffn
+
+@deffn {Scheme Procedure} value->real
+Return the Scheme real number representing @code{<gdb:value>} @var{value}.
+The value must be a number.
+@end deffn
+
+@deffn {Scheme Procedure} value->bytevector
+Return a Scheme bytevector with the raw contents of @code{<gdb:value>}
+@var{value}. No transformation, endian or otherwise, is performed.
+@end deffn
+
+@c TODO: line length
+@deffn {Scheme Procedure} value->string value @r{[}#:encoding encoding@r{]} @r{[}#:errors errors@r{]} @r{[}#:length length@r{]}
+If @var{value>} represents a string, then this method
+converts the contents to a Guile string. Otherwise, this method will
+throw an exception.
+
+Values are interpreted as strings according to the rules of the
+current language. If the optional length argument is given, the
+string will be converted to that length, and will include any embedded
+zeroes that the string may contain. Otherwise, for languages
+where the string is zero-terminated, the entire string will be
+converted.
+
+For example, in C-like languages, a value is a string if it is a pointer
+to or an array of characters or ints of type @code{wchar_t}, @code{char16_t},
+or @code{char32_t}.
+
+If the optional @var{encoding} argument is given, it must be a string
+naming the encoding of the string in the @code{<gdb:value>}, such as
+@code{"ascii"}, @code{"iso-8859-6"} or @code{"utf-8"}. It accepts
+the same encodings as the corresponding argument to Guile's
+@code{scm_from_stringn} function, and the Guile codec machinery will be used
+to convert the string. If @var{encoding} is not given, or if
+@var{encoding} is the empty string, then either the @code{target-charset}
+(@pxref{Character Sets}) will be used, or a language-specific encoding
+will be used, if the current language is able to supply one.
+
+The optional @var{errors} argument is one of @code{#f}, @code{error} or
+@code{substitute}. @code{error} and @code{substitute} must be symbols.
+If @var{errors} is not specified, or if its value is @code{#f}, then the
+default conversion strategy is used, which is set with the Scheme function
+@code{set-port-conversion-strategy!}.
+If the value is @code{'error} then an exception is thrown if there is any
+conversion error. If the value is @code{'substitute} then any conversion
+error is replaced with question marks.
+@xref{Strings,,, guile, GNU Guile Reference Manual}.
+
+If the optional @var{length} argument is given, the string will be
+fetched and converted to the given length.
+The length must be a Scheme integer and not a @code{<gdb:value>} integer.
+@end deffn
+
+@c TODO: line length
+@deffn {Scheme Procedure} value->lazy-string value @r{[}#:encoding encoding@r{]} @r{[}#:length length@r{]})
+If this @code{<gdb:value>} represents a string, then this method
+converts @var{value} to a @code{<gdb:lazy-string} (@pxref{Lazy Strings
+In Guile}). Otherwise, this method will throw an exception.
+
+If the optional @var{encoding} argument is given, it must be a string
+naming the encoding of the @code{<gdb:lazy-string}. Some examples are:
+@code{"ascii"}, @code{"iso-8859-6"} or @code{"utf-8"}. If the
+@var{encoding} argument is an encoding that @value{GDBN} does not
+recognize, @value{GDBN} will raise an error.
+
+When a lazy string is printed, the @value{GDBN} encoding machinery is
+used to convert the string during printing. If the optional
+@var{encoding} argument is not provided, or is an empty string,
+@value{GDBN} will automatically select the encoding most suitable for
+the string type. For further information on encoding in @value{GDBN}
+please see @ref{Character Sets}.
+
+If the optional @var{length} argument is given, the string will be
+fetched and encoded to the length of characters specified. If
+the @var{length} argument is not provided, the string will be fetched
+and encoded until a null of appropriate width is found.
+The length must be a Scheme integer and not a @code{<gdb:value>} integer.
+@end deffn
+
+@deffn {Scheme Procedure} value-lazy? value
+Return @code{#t} if @var{value} has not yet been fetched
+from the inferior.
+Otherwise return @code{#f}.
+@value{GDBN} does not fetch values until necessary, for efficiency.
+For example:
+
+@smallexample
+(define myval (parse-and-eval "somevar"))
+@end smallexample
+
+The value of @code{somevar} is not fetched at this time. It will be
+fetched when the value is needed, or when the @code{fetch-lazy}
+procedure is invoked.
+@end deffn
+
+@deffn {Scheme Procedure} make-lazy-value type address
+Return a @code{<gdb:value>} that will be lazily fetched from the target.
+@var{type} is an object of type @code{<gdb:type>} and @var{address} is
+a Scheme integer of the address of the object in target memory.
+@end deffn
+
+@deffn {Scheme Procedure} value-fetch-lazy! value
+If @var{value} is a lazy value (@code{(value-lazy? value)} is @code{#t}),
+then the value is fetched from the inferior.
+Any errors that occur in the process will produce a Guile exception.
+
+If @var{value} is not a lazy value, this method has no effect.
+
+The result of this function is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} value-print value
+Return the string representation (print form) of @code{<gdb:value>}
+@var{value}.
+@end deffn
+
+@node Arithmetic In Guile
+@subsubsection Arithmetic In Guile
+
+The @code{(gdb)} module provides several functions for performing
+arithmetic on @code{<gdb:value>} objects.
+The arithmetic is performed as if it were done by the target,
+and therefore has target semantics which are not necessarily
+those of Scheme. For example operations work with a fixed precision,
+not the arbitrary precision of Scheme.
+
+Wherever a function takes an integer or pointer as an operand,
+@value{GDBN} will convert appropriate Scheme values to perform
+the operation.
+
+@deffn {Scheme Procedure} value-add a b
+@end deffn
+
+@deffn {Scheme Procedure} value-sub a b
+@end deffn
+
+@deffn {Scheme Procedure} value-mul a b
+@end deffn
+
+@deffn {Scheme Procedure} value-div a b
+@end deffn
+
+@deffn {Scheme Procedure} value-rem a b
+@end deffn
+
+@deffn {Scheme Procedure} value-mod a b
+@end deffn
+
+@deffn {Scheme Procedure} value-pow a b
+@end deffn
+
+@deffn {Scheme Procedure} value-not a
+@end deffn
+
+@deffn {Scheme Procedure} value-neg a
+@end deffn
+
+@deffn {Scheme Procedure} value-pos a
+@end deffn
+
+@deffn {Scheme Procedure} value-abs a
+@end deffn
+
+@deffn {Scheme Procedure} value-lsh a b
+@end deffn
+
+@deffn {Scheme Procedure} value-rsh a b
+@end deffn
+
+@deffn {Scheme Procedure} value-min a b
+@end deffn
+
+@deffn {Scheme Procedure} value-max a b
+@end deffn
+
+@deffn {Scheme Procedure} value-lognot a
+@end deffn
+
+@deffn {Scheme Procedure} value-logand a b
+@end deffn
+
+@deffn {Scheme Procedure} value-logior a b
+@end deffn
+
+@deffn {Scheme Procedure} value-logxor a b
+@end deffn
+
+@deffn {Scheme Procedure} value=? a b
+@end deffn
+
+@deffn {Scheme Procedure} value<? a b
+@end deffn
+
+@deffn {Scheme Procedure} value<=? a b
+@end deffn
+
+@deffn {Scheme Procedure} value>? a b
+@end deffn
+
+@deffn {Scheme Procedure} value>=? a b
+@end deffn
+
+Scheme does not provide a @code{not-equal} function,
+and thus Guile support in @value{GDBN} does not either.
+
+@node Types In Guile
+@subsubsection Types In Guile
+@cindex types in guile
+@cindex guile, working with types
+
+@tindex <gdb:type>
+@value{GDBN} represents types from the inferior in objects of type
+@code{<gdb:type>}.
+
+The following type-related procedures are provided by the
+@code{(gdb)} module.
+
+@deffn {Scheme Procedure} type? object
+Return @code{#t} if @var{object} is an object of type @code{<gdb:type>}.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} lookup-type name @r{[}#:block block@r{]}
+This function looks up a type by name. @var{name} is the name of the
+type to look up. It must be a string.
+
+If @var{block} is given, it is an object of type @code{<gdb:block>},
+and @var{name} is looked up in that scope.
+Otherwise, it is searched for globally.
+
+Ordinarily, this function will return an instance of @code{<gdb:type>}.
+If the named type cannot be found, it will throw an exception.
+@end deffn
+
+@deffn {Scheme Procedure} type-code type
+Return the type code of @var{type}. The type code will be one of the
+@code{TYPE_CODE_} constants defined below.
+@end deffn
+
+@deffn {Scheme Procedure} type-tag type
+Return the tag name of @var{type}. The tag name is the name after
+@code{struct}, @code{union}, or @code{enum} in C and C@t{++}; not all
+languages have this concept. If this type has no tag name, then
+@code{#f} is returned.
+@end deffn
+
+@deffn {Scheme Procedure} type-name type
+Return the name of @var{type}.
+If this type has no name, then @code{#f} is returned.
+@end deffn
+
+@deffn {Scheme Procedure} type-print-name type
+Return the print name of @var{type}.
+This returns something even for anonymous types.
+For example, for an anonymous C struct @code{"struct @{...@}"} is returned.
+@end deffn
+
+@deffn {Scheme Procedure} type-sizeof type
+Return the size of this type, in target @code{char} units. Usually, a
+target's @code{char} type will be an 8-bit byte. However, on some
+unusual platforms, this type may have a different size.
+@end deffn
+
+@deffn {Scheme Procedure} type-strip-typedefs type
+Return a new @code{<gdb:type>} that represents the real type of @var{type},
+after removing all layers of typedefs.
+@end deffn
+
+@deffn {Scheme Procedure} type-array type n1 @r{[}n2@r{]}
+Return a new @code{<gdb:type>} object which represents an array of this
+type. If one argument is given, it is the inclusive upper bound of
+the array; in this case the lower bound is zero. If two arguments are
+given, the first argument is the lower bound of the array, and the
+second argument is the upper bound of the array. An array's length
+must not be negative, but the bounds can be.
+@end deffn
+
+@deffn {Scheme Procedure} type-vector type n1 @r{[}n2@r{]}
+Return a new @code{<gdb:type>} object which represents a vector of this
+type. If one argument is given, it is the inclusive upper bound of
+the vector; in this case the lower bound is zero. If two arguments are
+given, the first argument is the lower bound of the vector, and the
+second argument is the upper bound of the vector. A vector's length
+must not be negative, but the bounds can be.
+
+The difference between an @code{array} and a @code{vector} is that
+arrays behave like in C: when used in expressions they decay to a pointer
+to the first element whereas vectors are treated as first class values.
+@end deffn
+
+@deffn {Scheme Procedure} type-pointer type
+Return a new @code{<gdb:type>} object which represents a pointer to
+@var{type}.
+@end deffn
+
+@deffn {Scheme Procedure} type-range type
+Return a list of two elements: the low bound and high bound of @var{type}.
+If @var{type} does not have a range, an exception is thrown.
+@end deffn
+
+@deffn {Scheme Procedure} type-reference type
+Return a new @code{<gdb:type>} object which represents a reference to
+@var{type}.
+@end deffn
+
+@deffn {Scheme Procedure} type-target type
+Return a new @code{<gdb:type>} object which represents the target type
+of @var{type}.
+
+For a pointer type, the target type is the type of the pointed-to
+object. For an array type (meaning C-like arrays), the target type is
+the type of the elements of the array. For a function or method type,
+the target type is the type of the return value. For a complex type,
+the target type is the type of the elements. For a typedef, the
+target type is the aliased type.
+
+If the type does not have a target, this method will throw an
+exception.
+@end deffn
+
+@deffn {Scheme Procedure} type-const type
+Return a new @code{<gdb:type>} object which represents a
+@code{const}-qualified variant of @var{type}.
+@end deffn
+
+@deffn {Scheme Procedure} type-volatile type
+Return a new @code{<gdb:type>} object which represents a
+@code{volatile}-qualified variant of @var{type}.
+@end deffn
+
+@deffn {Scheme Procedure} type-unqualified type
+Return a new @code{<gdb:type>} object which represents an unqualified
+variant of @var{type}. That is, the result is neither @code{const} nor
+@code{volatile}.
+@end deffn
+
+@deffn {Scheme Procedure} type-num-fields
+Return the number of fields of @code{<gdb:type>} @var{type}.
+@end deffn
+
+@deffn {Scheme Procedure} type-fields type
+Return the fields of @var{type} as a list.
+For structure and union types, @code{fields} has the usual meaning.
+Range types have two fields, the minimum and maximum values. Enum types
+have one field per enum constant. Function and method types have one
+field per parameter. The base types of C@t{++} classes are also
+represented as fields. If the type has no fields, or does not fit
+into one of these categories, an empty list will be returned.
+@xref{Fields of a type in Guile}.
+@end deffn
+
+@deffn {Scheme Procedure} make-field-iterator type
+Return the fields of @var{type} as a <gdb:iterator> object.
+@xref{Iterators In Guile}.
+@end deffn
+
+@deffn {Scheme Procedure} type-field type field-name
+Return field named @var{field-name} in @var{type}.
+The result is an object of type @code{<gdb:field>}.
+@xref{Fields of a type in Guile}.
+If the type does not have fields, or @var{field-name} is not a field
+of @var{type}, an exception is thrown.
+
+For example, if @code{some-type} is a @code{<gdb:type>} instance holding
+a structure type, you can access its @code{foo} field with:
+
+@smallexample
+(define bar (type-field some-type "foo"))
+@end smallexample
+
+@code{bar} will be a @code{<gdb:field>} object.
+@end deffn
+
+@deffn {Scheme Procedure} type-has-field? type name
+Return @code{#t} if @code{<gdb:type>} @var{type} has field named @var{name}.
+Otherwise return @code{#f}.
+@end deffn
+
+Each type has a code, which indicates what category this type falls
+into. The available type categories are represented by constants
+defined in the @code{(gdb)} module:
+
+@vtable @code
+@item TYPE_CODE_PTR
+The type is a pointer.
+
+@item TYPE_CODE_ARRAY
+The type is an array.
+
+@item TYPE_CODE_STRUCT
+The type is a structure.
+
+@item TYPE_CODE_UNION
+The type is a union.
+
+@item TYPE_CODE_ENUM
+The type is an enum.
+
+@item TYPE_CODE_FLAGS
+A bit flags type, used for things such as status registers.
+
+@item TYPE_CODE_FUNC
+The type is a function.
+
+@item TYPE_CODE_INT
+The type is an integer type.
+
+@item TYPE_CODE_FLT
+A floating point type.
+
+@item TYPE_CODE_VOID
+The special type @code{void}.
+
+@item TYPE_CODE_SET
+A Pascal set type.
+
+@item TYPE_CODE_RANGE
+A range type, that is, an integer type with bounds.
+
+@item TYPE_CODE_STRING
+A string type. Note that this is only used for certain languages with
+language-defined string types; C strings are not represented this way.
+
+@item TYPE_CODE_BITSTRING
+A string of bits. It is deprecated.
+
+@item TYPE_CODE_ERROR
+An unknown or erroneous type.
+
+@item TYPE_CODE_METHOD
+A method type, as found in C@t{++} or Java.
+
+@item TYPE_CODE_METHODPTR
+A pointer-to-member-function.
+
+@item TYPE_CODE_MEMBERPTR
+A pointer-to-member.
+
+@item TYPE_CODE_REF
+A reference type.
+
+@item TYPE_CODE_CHAR
+A character type.
+
+@item TYPE_CODE_BOOL
+A boolean type.
+
+@item TYPE_CODE_COMPLEX
+A complex float type.
+
+@item TYPE_CODE_TYPEDEF
+A typedef to some other type.
+
+@item TYPE_CODE_NAMESPACE
+A C@t{++} namespace.
+
+@item TYPE_CODE_DECFLOAT
+A decimal floating point type.
+
+@item TYPE_CODE_INTERNAL_FUNCTION
+A function internal to @value{GDBN}. This is the type used to represent
+convenience functions (@pxref{Convenience Funs}).
+@end vtable
+
+Further support for types is provided in the @code{(gdb types)}
+Guile module (@pxref{Guile Types Module}).
+
+@anchor{Fields of a type in Guile}
+Each field is represented as an object of type @code{<gdb:field>}.
+
+The following field-related procedures are provided by the
+@code{(gdb)} module:
+
+@deffn {Scheme Procedure} field? object
+Return @code{#t} if @var{object} is an object of type @code{<gdb:field>}.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} field-name field
+Return the name of the field, or @code{#f} for anonymous fields.
+@end deffn
+
+@deffn {Scheme Procedure} field-type field
+Return the type of the field. This is usually an instance of
+@code{<gdb:type>}, but it can be @code{#f} in some situations.
+@end deffn
+
+@deffn {Scheme Procedure} field-enumval field
+Return the enum value represented by @code{<gdb:field>} @var{field}.
+@end deffn
+
+@deffn {Scheme Procedure} field-bitpos field
+Return the bit position of @code{<gdb:field>} @var{field}.
+This attribute is not available for @code{static} fields (as in
+C@t{++} or Java).
+@end deffn
+
+@deffn {Scheme Procedure} field-bitsize field
+If the field is packed, or is a bitfield, return the size of
+@code{<gdb:field>} @var{field} in bits. Otherwise, zero is returned;
+in which case the field's size is given by its type.
+@end deffn
+
+@deffn {Scheme Procedure} field-artificial? field
+Return @code{#t} if the field is artificial, usually meaning that
+it was provided by the compiler and not the user.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} field-base-class? field
+Return @code{#t} if the field represents a base class of a C@t{++}
+structure.
+Otherwise return @code{#f}.
+@end deffn
+
+@node Guile Pretty Printing API
+@subsubsection Guile Pretty Printing API
+@cindex guile pretty printing api
+
+An example output is provided (@pxref{Pretty Printing}).
+
+A pretty-printer is represented by an object of type <gdb:pretty-printer>.
+Pretty-printer objects are created with @code{make-pretty-printer}.
+
+The following pretty-printer-related procedures are provided by the
+@code{(gdb)} module:
+
+@deffn {Scheme Procedure} make-pretty-printer name lookup-function
+Return a @code{<gdb:pretty-printer>} object named @var{name}.
+
+@var{lookup-function} is a function of one parameter: the value to
+be printed. If the value is handled by this pretty-printer, then
+@var{lookup-function} returns an object of type
+<gdb:pretty-printer-worker> to perform the actual pretty-printing.
+Otherwise @var{lookup-function} returns @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} pretty-printer? object
+Return @code{#t} if @var{object} is a @code{<gdb:pretty-printer>} object.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} pretty-printer-enabled? pretty-printer
+Return @code{#t} if @var{pretty-printer} is enabled.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} set-pretty-printer-enabled! pretty-printer flag
+Set the enabled flag of @var{pretty-printer} to @var{flag}.
+The value returned in unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} make-pretty-printer-worker display-hint to-string children
+Return an object of type @code{<gdb:pretty-printer-worker>}.
+
+This function takes three parameters:
+
+@table @samp
+@item display-hint
+@var{display-hint} provides a hint to @value{GDBN} or @value{GDBN}
+front end via MI to change the formatting of the value being printed.
+The value must be a string or @code{#f} (meaning there is no hint).
+Several values for @var{display-hint}
+are predefined by @value{GDBN}:
+
+@table @samp
+@item array
+Indicate that the object being printed is ``array-like''. The CLI
+uses this to respect parameters such as @code{set print elements} and
+@code{set print array}.
+
+@item map
+Indicate that the object being printed is ``map-like'', and that the
+children of this value can be assumed to alternate between keys and
+values.
+
+@item string
+Indicate that the object being printed is ``string-like''. If the
+printer's @code{to-string} function returns a Guile string of some
+kind, then @value{GDBN} will call its internal language-specific
+string-printing function to format the string. For the CLI this means
+adding quotation marks, possibly escaping some characters, respecting
+@code{set print elements}, and the like.
+@end table
+
+@item to-string
+@var{to-string} is either a function of one parameter, the
+@code{<gdb:pretty-printer-worker>} object, or @code{#f}.
+
+When printing from the CLI, if the @code{to-string} method exists,
+then @value{GDBN} will prepend its result to the values returned by
+@code{children}. Exactly how this formatting is done is dependent on
+the display hint, and may change as more hints are added. Also,
+depending on the print settings (@pxref{Print Settings}), the CLI may
+print just the result of @code{to-string} in a stack trace, omitting
+the result of @code{children}.
+
+If this method returns a string, it is printed verbatim.
+
+Otherwise, if this method returns an instance of @code{<gdb:value>},
+then @value{GDBN} prints this value. This may result in a call to
+another pretty-printer.
+
+If instead the method returns a Guile value which is convertible to a
+@code{<gdb:value>}, then @value{GDBN} performs the conversion and prints
+the resulting value. Again, this may result in a call to another
+pretty-printer. Guile scalars (integers, floats, and booleans) and
+strings are convertible to @code{<gdb:value>}; other types are not.
+
+Finally, if this method returns @code{#f} then no further operations
+are peformed in this method and nothing is printed.
+
+If the result is not one of these types, an exception is raised.
+
+@var{to-string} may also be @code{#f} in which case it is left to
+@var{children} to print the value.
+
+@item children
+@var{children} is either a function of one parameter, the
+@code{<gdb:pretty-printer-worker>} object, or @code{#f}.
+
+@value{GDBN} will call this function on a pretty-printer to compute the
+children of the pretty-printer's value.
+
+This function must return a <gdb:iterator> object.
+Each item returned by the iterator must be a tuple holding
+two elements. The first element is the ``name'' of the child; the
+second element is the child's value. The value can be any Guile
+object which is convertible to a @value{GDBN} value.
+
+If @var{children} is @code{#f}, @value{GDBN} will act
+as though the value has no children.
+@end table
+@end deffn
+
+@value{GDBN} provides a function which can be used to look up the
+default pretty-printer for a @code{<gdb:value>}:
+
+@deffn {Scheme Procedure} default-visualizer value
+This function takes a @code{<gdb:value>} object as an argument. If a
+pretty-printer for this value exists, then it is returned. If no such
+printer exists, then this returns @code{#f}.
+@end deffn
+
+@node Selecting Guile Pretty-Printers
+@subsubsection Selecting Guile Pretty-Printers
+@cindex selecting guile pretty-printers
+
+The Guile list @code{*pretty-printers*} contains a set of
+@code{<gdb:pretty-printer>} registered objects.
+Printers in this list are called @code{global}
+printers, they're available when debugging any inferior.
+In addition to this, each @code{<gdb:objfile>} object contains its
+own set of pretty-printers (@pxref{Objfiles In Guile}).
+
+Pretty-printer lookup is done by passing the value to be printed to the
+lookup function of each enabled object in turn.
+Lookup stops when a lookup function returns a non-@code{#f} value
+or when the list is exhausted.
+
+@value{GDBN} first checks the result of @code{objfile-pretty-printers}
+of each @code{<gdb:objfile>} in the current program space and iteratively
+calls each enabled lookup function in the list for that @code{<gdb:objfile>}
+until a non-@code{#f} object is returned.
+Lookup functions must return either a @code{<gdb:pretty-printer-worker>}
+object or @code{#f}. Otherwise an exception is thrown.
+If no pretty-printer is found in the objfile lists, @value{GDBN} then
+searches the global pretty-printer list, calling each enabled function
+until a non-@code{#f} object is returned.
+
+The order in which the objfiles are searched is not specified. For a
+given list, functions are always invoked from the head of the list,
+and iterated over sequentially until the end of the list, or a
+@code{<gdb:pretty-printer-worker>} object is returned.
+
+For various reasons a pretty-printer may not work.
+For example, the underlying data structure may have changed and
+the pretty-printer is out of date.
+
+The consequences of a broken pretty-printer are severe enough that
+@value{GDBN} provides support for enabling and disabling individual
+printers. For example, if @code{print frame-arguments} is on,
+a backtrace can become highly illegible if any argument is printed
+with a broken printer.
+
+Pretty-printers are enabled and disabled from Scheme by calling
+@code{set-pretty-printer-enabled!}.
+@xref{Guile Pretty Printing API}.
+
+@node Writing a Guile Pretty-Printer
+@subsubsection Writing a Guile Pretty-Printer
+@cindex writing a Guile pretty-printer
+
+A pretty-printer consists of two basic parts: a lookup function to determine
+if the type is supported, and the printer itself.
+
+Here is an example showing how a @code{std::string} printer might be
+written. @xref{Guile Pretty Printing API}, for details.
+
+@smallexample
+(define (make-my-string-printer value)
+ "Print a my::string string"
+ (make-pretty-printer-worker
+ "string"
+ (lambda (printer)
+ (value-field value "_data"))
+ #f))
+@end smallexample
+
+And here is an example showing how a lookup function for the printer
+example above might be written.
+
+@smallexample
+(define (string-begins-with str prefix)
+ (= (string-prefix-length str prefix) (string-length prefix)))
+
+(define (str-lookup-function value)
+ (let ((tag (type-tag (value-type value))))
+ (and tag
+ (string-begins-with tag "my::string<")
+ (make-std-string-printer value))))
+@end smallexample
+
+Then to register this printer in the global printer list:
+
+@smallexample
+(append-pretty-printer!
+ (make-pretty-printer "my-string" str-lookup-function))
+@end smallexample
+
+The example lookup function extracts the value's type, and attempts to
+match it to a type that it can pretty-print. If it is a type the
+printer can pretty-print, it will return a <gdb:pretty-printer-worker> object.
+If not, it returns @code{#f}.
+
+We recommend that you put your core pretty-printers into a Guile
+package. If your pretty-printers are for use with a library, we
+further recommend embedding a version number into the package name.
+This practice will enable @value{GDBN} to load multiple versions of
+your pretty-printers at the same time, because they will have
+different names.
+
+You should write auto-loaded code (@pxref{Guile Auto-loading}) such that it
+can be evaluated multiple times without changing its meaning. An
+ideal auto-load file will consist solely of @code{import}s of your
+printer modules, followed by a call to a register pretty-printers with
+the current objfile.
+
+Taken as a whole, this approach will scale nicely to multiple
+inferiors, each potentially using a different library version.
+Embedding a version number in the Guile package name will ensure that
+@value{GDBN} is able to load both sets of printers simultaneously.
+Then, because the search for pretty-printers is done by objfile, and
+because your auto-loaded code took care to register your library's
+printers with a specific objfile, @value{GDBN} will find the correct
+printers for the specific version of the library used by each
+inferior.
+
+To continue the @code{my::string} example,
+this code might appear in @code{(my-project my-library v1)}:
+
+@smallexample
+(use-modules ((gdb)))
+(define (register-printers objfile)
+ (append-objfile-pretty-printer!
+ (make-pretty-printer "my-string" str-lookup-function)))
+@end smallexample
+
+@noindent
+And then the corresponding contents of the auto-load file would be:
+
+@smallexample
+(use-modules ((gdb) (my-project my-library v1)))
+(register-printers (current-objfile))
+@end smallexample
+
+The previous example illustrates a basic pretty-printer.
+There are a few things that can be improved on.
+The printer only handles one type, whereas a library typically has
+several types. One could install a lookup function for each desired type
+in the library, but one could also have a single lookup function recognize
+several types. The latter is the conventional way this is handled.
+If a pretty-printer can handle multiple data types, then its
+@dfn{subprinters} are the printers for the individual data types.
+
+The @code{(gdb printing)} module provides a formal way of solving this
+problem (@pxref{Guile Printing Module}).
+Here is another example that handles multiple types.
+
+These are the types we are going to pretty-print:
+
+@smallexample
+struct foo @{ int a, b; @};
+struct bar @{ struct foo x, y; @};
+@end smallexample
+
+Here are the printers:
+
+@smallexample
+(define (make-foo-printer value)
+ "Print a foo object"
+ (make-pretty-printer-worker
+ "foo"
+ (lambda (printer)
+ (format #f "a=<~a> b=<~a>"
+ (value-field value "a") (value-field value "a")))
+ #f))
+
+(define (make-bar-printer value)
+ "Print a bar object"
+ (make-pretty-printer-worker
+ "foo"
+ (lambda (printer)
+ (format #f "x=<~a> y=<~a>"
+ (value-field value "x") (value-field value "y")))
+ #f))
+@end smallexample
+
+This example doesn't need a lookup function, that is handled by the
+@code{(gdb printing)} module. Instead a function is provided to build up
+the object that handles the lookup.
+
+@smallexample
+(use-modules ((gdb printing)))
+
+(define (build-pretty-printer)
+ (let ((pp (make-pretty-printer-collection "my-library")))
+ (pp-collection-add-tag-printer "foo" make-foo-printer)
+ (pp-collection-add-tag-printer "bar" make-bar-printer)
+ pp))
+@end smallexample
+
+And here is the autoload support:
+
+@smallexample
+(use-modules ((gdb) (my-library)))
+(append-objfile-pretty-printer! (current-objfile) (build-pretty-printer))
+@end smallexample
+
+Finally, when this printer is loaded into @value{GDBN}, here is the
+corresponding output of @samp{info pretty-printer}:
+
+@smallexample
+(gdb) info pretty-printer
+my_library.so:
+ my-library
+ foo
+ bar
+@end smallexample
+
+@node Objfiles In Guile
+@subsubsection Objfiles In Guile
+
+@cindex objfiles in guile
+@tindex <gdb:objfile>
+@value{GDBN} loads symbols for an inferior from various
+symbol-containing files (@pxref{Files}). These include the primary
+executable file, any shared libraries used by the inferior, and any
+separate debug info files (@pxref{Separate Debug Files}).
+@value{GDBN} calls these symbol-containing files @dfn{objfiles}.
+
+Each objfile is represented as an object of type @code{<gdb:objfile>}.
+
+The following objfile-related procedures are provided by the
+@code{(gdb)} module:
+
+@deffn {Scheme Procedure} objfile? object
+Return @code{#t} if @var{object} is a @code{<gdb:objfile>} object.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} objfile-valid? objfile
+Return @code{#t} if @var{objfile} is valid, @code{#f} if not.
+A @code{<gdb:objfile>} object can become invalid
+if the object file it refers to is not loaded in @value{GDBN} any
+longer. All other @code{<gdb:objfile>} procedures will throw an exception
+if it is invalid at the time the procedure is called.
+@end deffn
+
+@deffn {Scheme Procedure} objfile-filename objfile
+Return the file name of @var{objfile} as a string.
+@end deffn
+
+@deffn {Scheme Procedure} objfile-pretty-printers objfile
+Return the list of registered @code{<gdb:pretty-printer>} objects for
+@var{objfile}. @xref{Guile Pretty Printing API}, for more information.
+@end deffn
+
+@deffn {Scheme Procedure} set-objfile-pretty-printers! objfile printer-list
+Set the list of registered @code{<gdb:pretty-printer>} objects for
+@var{objfile} to @var{printer-list}.
+@var{printer-list} must be a list of @code{<gdb:pretty-printer>} objects.
+@xref{Guile Pretty Printing API}, for more information.
+@end deffn
+
+@deffn {Scheme Procedure} current-objfile
+When auto-loading a Guile script (@pxref{Guile Auto-loading}), @value{GDBN}
+sets the ``current objfile'' to the corresponding objfile. This
+function returns the current objfile. If there is no current objfile,
+this function returns @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} objfiles
+Return a list of all the objfiles in the current program space.
+@end deffn
+
+@node Frames In Guile
+@subsubsection Accessing inferior stack frames from Guile.
+
+@cindex frames in guile
+When the debugged program stops, @value{GDBN} is able to analyze its call
+stack (@pxref{Frames,,Stack frames}). The @code{<gdb:frame>} class
+represents a frame in the stack. A @code{<gdb:frame>} object is only valid
+while its corresponding frame exists in the inferior's stack. If you try
+to use an invalid frame object, @value{GDBN} will throw a
+@code{gdb:invalid-object} exception (@pxref{Guile Exception Handling}).
+
+Two @code{<gdb:frame>} objects can be compared for equality with the
+@code{equal?} function, like:
+
+@smallexample
+(@value{GDBP}) guile (equal? (newest-frame) (selected-frame))
+#t
+@end smallexample
+
+The following frame-related procedures are provided by the
+@code{(gdb)} module:
+
+@deffn {Scheme Procedure} frame? object
+Return @code{#t} if @var{object} is a @code{<gdb:frame>} object.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} frame-valid? frame
+Returns @code{#t} if @var{frame} is valid, @code{#f} if not.
+A frame object can become invalid if the frame it refers to doesn't
+exist anymore in the inferior. All @code{<gdb:frame>} procedures will throw
+an exception if the frame is invalid at the time the procedure is called.
+@end deffn
+
+@deffn {Scheme Procedure} frame-name frame
+Return the function name of @var{frame}, or @code{#f} if it can't be
+obtained.
+@end deffn
+
+@deffn {Scheme Procedure} frame-arch frame
+Return the @code{<gdb:architecture>} object corresponding to @var{frame}'s
+architecture. @xref{Architectures In Guile}.
+@end deffn
+
+@deffn {Scheme Procedure} frame-type frame
+Return the type of @var{frame}. The value can be one of:
+
+@table @code
+@item NORMAL_FRAME
+An ordinary stack frame.
+
+@item DUMMY_FRAME
+A fake stack frame that was created by @value{GDBN} when performing an
+inferior function call.
+
+@item INLINE_FRAME
+A frame representing an inlined function. The function was inlined
+into a @code{NORMAL_FRAME} that is older than this one.
+
+@item TAILCALL_FRAME
+A frame representing a tail call. @xref{Tail Call Frames}.
+
+@item SIGTRAMP_FRAME
+A signal trampoline frame. This is the frame created by the OS when
+it calls into a signal handler.
+
+@item ARCH_FRAME
+A fake stack frame representing a cross-architecture call.
+
+@item SENTINEL_FRAME
+This is like @code{NORMAL_FRAME}, but it is only used for the
+newest frame.
+@end table
+@end deffn
+
+@deffn {Scheme Procedure} frame-unwind-stop-reason frame
+Return an integer representing the reason why it's not possible to find
+more frames toward the outermost frame. Use
+@code{unwind-stop-reason-string} to convert the value returned by this
+function to a string. The value can be one of:
+
+@table @code
+@item FRAME_UNWIND_NO_REASON
+No particular reason (older frames should be available).
+
+@item FRAME_UNWIND_NULL_ID
+The previous frame's analyzer returns an invalid result.
+
+@item FRAME_UNWIND_OUTERMOST
+This frame is the outermost.
+
+@item FRAME_UNWIND_UNAVAILABLE
+Cannot unwind further, because that would require knowing the
+values of registers or memory that have not been collected.
+
+@item FRAME_UNWIND_INNER_ID
+This frame ID looks like it ought to belong to a NEXT frame,
+but we got it for a PREV frame. Normally, this is a sign of
+unwinder failure. It could also indicate stack corruption.
+
+@item FRAME_UNWIND_SAME_ID
+This frame has the same ID as the previous one. That means
+that unwinding further would almost certainly give us another
+frame with exactly the same ID, so break the chain. Normally,
+this is a sign of unwinder failure. It could also indicate
+stack corruption.
+
+@item FRAME_UNWIND_NO_SAVED_PC
+The frame unwinder did not find any saved PC, but we needed
+one to unwind further.
+
+@item FRAME_UNWIND_FIRST_ERROR
+Any stop reason greater or equal to this value indicates some kind
+of error. This special value facilitates writing code that tests
+for errors in unwinding in a way that will work correctly even if
+the list of the other values is modified in future @value{GDBN}
+versions. Using it, you could write:
+
+@smallexample
+(define reason (frame-unwind-stop-readon (selected-frame)))
+(define reason-str (unwind-stop-reason-string reason))
+(if (>= reason FRAME_UNWIND_FIRST_ERROR)
+ (format #t "An error occured: ~s\n" reason-str))
+@end smallexample
+@end table
+@end deffn
+
+@deffn {Scheme Procedure} frame-pc frame
+Return the frame's resume address.
+@end deffn
+
+@deffn {Scheme Procedure} frame-block frame
+Return the frame's code block as a @code{<gdb:block>} object.
+@xref{Blocks In Guile}.
+@end deffn
+
+@deffn {Scheme Procedure} frame-function frame
+Return the symbol for the function corresponding to this frame
+as a @code{<gdb:symbol>} object, or @code{#f} if there isn't one.
+@xref{Symbols In Guile}.
+@end deffn
+
+@deffn {Scheme Procedure} frame-older frame
+Return the frame that called @var{frame}.
+@end deffn
+
+@deffn {Scheme Procedure} frame-newer frame
+Return the frame called by @var{frame}.
+@end deffn
+
+@deffn {Scheme Procedure} frame-sal frame
+Return the frame's @code{<gdb:sal>} (symtab and line) object.
+@xref{Symbol Tables In Guile}.
+@end deffn
+
+@deffn {Scheme Procedure} frame-read-var variable @r{[}#:block block@r{]}
+Return the value of @var{variable} in this frame. If the optional
+argument @var{block} is provided, search for the variable from that
+block; otherwise start at the frame's current block (which is
+determined by the frame's current program counter). @var{variable}
+must be a string or a @code{<gdb:symbol>} object. @var{block} must be a
+@code{<gdb:block>} object.
+@end deffn
+
+@deffn {Scheme Procedure} frame-select frame
+Set @var{frame} to be the selected frame. @xref{Stack, ,Examining the
+Stack}.
+@end deffn
+
+@deffn {Scheme Procedure} selected-frame
+Return the selected frame object. @xref{Selection,,Selecting a Frame}.
+@end deffn
+
+@deffn {Scheme Procedure} newest-frame
+Return the newest frame object for the selected thread.
+@end deffn
+
+@deffn {Scheme Procedure} unwind-stop-reason-string reason
+Return a string explaining the reason why @value{GDBN} stopped unwinding
+frames, as expressed by the given @var{reason} code (an integer, see the
+@code{frame-unwind-stop-reason} procedure above in this section).
+@end deffn
+
+@node Blocks In Guile
+@subsubsection Accessing blocks from Guile.
+
+@cindex blocks in guile
+@tindex <gdb:block>
+
+In @value{GDBN}, symbols are stored in blocks. A block corresponds
+roughly to a scope in the source code. Blocks are organized
+hierarchically, and are represented individually in Guile as an object
+of type @code{<gdb:block>}. Blocks rely on debugging information being
+available.
+
+A frame has a block. Please see @ref{Frames In Guile}, for a more
+in-depth discussion of frames.
+
+The outermost block is known as the @dfn{global block}. The global
+block typically holds public global variables and functions.
+
+The block nested just inside the global block is the @dfn{static
+block}. The static block typically holds file-scoped variables and
+functions.
+
+@value{GDBN} provides a method to get a block's superblock, but there
+is currently no way to examine the sub-blocks of a block, or to
+iterate over all the blocks in a symbol table (@pxref{Symbol Tables In
+Guile}).
+
+Here is a short example that should help explain blocks:
+
+@smallexample
+/* This is in the global block. */
+int global;
+
+/* This is in the static block. */
+static int file_scope;
+
+/* 'function' is in the global block, and 'argument' is
+ in a block nested inside of 'function'. */
+int function (int argument)
+@{
+ /* 'local' is in a block inside 'function'. It may or may
+ not be in the same block as 'argument'. */
+ int local;
+
+ @{
+ /* 'inner' is in a block whose superblock is the one holding
+ 'local'. */
+ int inner;
+
+ /* If this call is expanded by the compiler, you may see
+ a nested block here whose function is 'inline_function'
+ and whose superblock is the one holding 'inner'. */
+ inline_function ();
+ @}
+@}
+@end smallexample
+
+The following block-related procedures are provided by the
+@code{(gdb)} module:
+
+@deffn {Scheme Procedure} block? object
+Return @code{#t} if @var{object} is a @code{<gdb:block>} object.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} block-valid? block
+Returns @code{#t} if @code{<gdb:block>} @var{block} is valid,
+@code{#f} if not. A block object can become invalid if the block it
+refers to doesn't exist anymore in the inferior. All other
+@code{<gdb:block>} methods will throw an exception if it is invalid at
+the time the procedure is called. The block's validity is also checked
+during iteration over symbols of the block.
+@end deffn
+
+@deffn {Scheme Procedure} block-start block
+Return the start address of @code{<gdb:block>} @var{block}.
+@end deffn
+
+@deffn {Scheme Procedure} block-end block
+Return the end address of @code{<gdb:block>} @var{block}.
+@end deffn
+
+@deffn {Scheme Procedure} block-function block
+Return the name of @code{<gdb:block>} @var{block} represented as a
+@code{<gdb:symbol>} object.
+If the block is not named, then @code{#f} is returned.
+
+For ordinary function blocks, the superblock is the static block.
+However, you should note that it is possible for a function block to
+have a superblock that is not the static block -- for instance this
+happens for an inlined function.
+@end deffn
+
+@deffn {Scheme Procedure} block-superblock block
+Return the block containing @code{<gdb:block>} @var{block}.
+If the parent block does not exist, then @code{#f} is returned.
+@end deffn
+
+@deffn {Scheme Procedure} block-global-block block
+Return the global block associated with @code{<gdb:block>} @var{block}.
+@end deffn
+
+@deffn {Scheme Procedure} block-static-block block
+Return the static block associated with @code{<gdb:block>} @var{block}.
+@end deffn
+
+@deffn {Scheme Procedure} block-global? block
+Return @code{#t} if @code{<gdb:block>} @var{block} is a global block.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} block-static? block
+Return @code{#t} if @code{<gdb:block>} @var{block} is a static block.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} block-symbols
+Return a list of all symbols (as <gdb:symbol> objects) in
+@code{<gdb:block>} @var{block}.
+@end deffn
+
+@deffn {Scheme Procedure} make-block-symbols-iterator block
+Return an object of type @code{<gdb:iterator>} that will iterate
+over all symbols of the block.
+Guile programs should not assume that a specific block object will
+always contain a given symbol, since changes in @value{GDBN} features and
+infrastructure may cause symbols move across blocks in a symbol table.
+@xref{Iterators In Guile}.
+@end deffn
+
+@deffn {Scheme Procedure} block-symbols-progress?
+Return #t if the object is a <gdb:block-symbols-progress> object.
+This object would be obtained from the @code{progress} element of the
+@code{<gdb:iterator>} object returned by @code{make-block-symbols-iterator}.
+@end deffn
+
+@deffn {Scheme Procedure} lookup-block pc
+Return the innermost @code{<gdb:block>} containing the given @var{pc}
+value. If the block cannot be found for the @var{pc} value specified,
+the function will return @code{#f}.
+@end deffn
+
+@node Symbols In Guile
+@subsubsection Guile representation of Symbols.
+
+@cindex symbols in guile
+@tindex <gdb:symbol>
+
+@value{GDBN} represents every variable, function and type as an
+entry in a symbol table. @xref{Symbols, ,Examining the Symbol Table}.
+Guile represents these symbols in @value{GDBN} with the
+@code{<gdb:symbol>} object.
+
+The following symbol-related procedures are provided by the
+@code{(gdb)} module:
+
+@deffn {Scheme Procedure} symbol? object
+Return @code{#t} if @var{object} is an object of type @code{<gdb:symbol>}.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-valid? symbol
+Return @code{#t} if the @code{<gdb:symbol>} object is valid,
+@code{#f} if not. A @code{<gdb:symbol>} object can become invalid if
+the symbol it refers to does not exist in @value{GDBN} any longer.
+All other @code{<gdb:symbol>} procedures will throw an exception if it is
+invalid at the time the procedure is called.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-type symbol
+Return the type of @var{symbol} or @code{#f} if no type is recorded.
+The result is an object of type @code{<gdb:type>}.
+@xref{Types In Guile}.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-symtab symbol
+Return the symbol table in which @var{symbol} appears.
+The result is an object of type @code{<gdb:symtab>}.
+@xref{Symbol Tables In Guile}.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-line symbol
+Return the line number in the source code at which @var{symbol} was defined.
+This is an integer.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-name symbol
+Return the name of @var{symbol} as a string.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-linkage-name symbol
+Return the name of @var{symbol}, as used by the linker (i.e., may be mangled).
+@end deffn
+
+@deffn {Scheme Procedure} symbol-print-name symbol
+Return the name of @var{symbol} in a form suitable for output. This is either
+@code{name} or @code{linkage_name}, depending on whether the user
+asked @value{GDBN} to display demangled or mangled names.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-addr-class symbol
+Return the address class of the symbol. This classifies how to find the value
+of a symbol. Each address class is a constant defined in the
+@code{(gdb)} module and described later in this chapter.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-needs-frame? symbol
+Return @code{#t} if evaluating @var{symbol}'s value requires a frame
+(@pxref{Frames In Guile}) and @code{#f} otherwise. Typically,
+local variables will require a frame, but other symbols will not.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-argument? symbol
+Return @code{#t} if @var{symbol} is an argument of a function.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-constant? symbol
+Return @code{#t} if @var{symbol} is a constant.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-function? symbol
+Return @code{#t} if @var{symbol} is a function or a method.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-variable? symbol
+Return @code{#t} if @var{symbol} is a variable.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} symbol-value symbol @r{[}#:frame frame@r{]}
+Compute the value of @var{symbol}, as a @code{<gdb:value>}. For
+functions, this computes the address of the function, cast to the
+appropriate type. If the symbol requires a frame in order to compute
+its value, then @var{frame} must be given. If @var{frame} is not
+given, or if @var{frame} is invalid, then an exception is thrown.
+@end deffn
+
+@c TODO: line length
+@deffn {Scheme Procedure} lookup-symbol name @r{[}#:block block@r{]} @r{[}#:domain domain@r{]}
+This function searches for a symbol by name. The search scope can be
+restricted to the parameters defined in the optional domain and block
+arguments.
+
+@var{name} is the name of the symbol. It must be a string. The
+optional @var{block} argument restricts the search to symbols visible
+in that @var{block}. The @var{block} argument must be a
+@code{<gdb:block>} object. If omitted, the block for the current frame
+is used. The optional @var{domain} argument restricts
+the search to the domain type. The @var{domain} argument must be a
+domain constant defined in the @code{(gdb)} module and described later
+in this chapter.
+
+The result is a list of two elements.
+The first element is a @code{<gdb:symbol>} object or @code{#f} if the symbol
+is not found.
+If the symbol is found, the second element is @code{#t} if the symbol
+is a field of a method's object (e.g., @code{this} in C@t{++}),
+otherwise it is @code{#f}.
+If the symbol is not found, the second element is @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} lookup-global-symbol name @r{[}#:domain domain@r{]}
+This function searches for a global symbol by name.
+The search scope can be restricted by the domain argument.
+
+@var{name} is the name of the symbol. It must be a string.
+The optional @var{domain} argument restricts the search to the domain type.
+The @var{domain} argument must be a domain constant defined in the @code{(gdb)}
+module and described later in this chapter.
+
+The result is a @code{<gdb:symbol>} object or @code{#f} if the symbol
+is not found.
+@end deffn
+
+The available domain categories in @code{<gdb:symbol>} are represented
+as constants in the @code{(gdb)} module:
+
+@vtable @code
+@item SYMBOL_UNDEF_DOMAIN
+This is used when a domain has not been discovered or none of the
+following domains apply. This usually indicates an error either
+in the symbol information or in @value{GDBN}'s handling of symbols.
+
+@item SYMBOL_VAR_DOMAIN
+This domain contains variables, function names, typedef names and enum
+type values.
+
+@item SYMBOL_STRUCT_DOMAIN
+This domain holds struct, union and enum type names.
+
+@item SYMBOL_LABEL_DOMAIN
+This domain contains names of labels (for gotos).
+
+@item SYMBOL_VARIABLES_DOMAIN
+This domain holds a subset of the @code{SYMBOLS_VAR_DOMAIN}; it
+contains everything minus functions and types.
+
+@item SYMBOL_FUNCTION_DOMAIN
+This domain contains all functions.
+
+@item SYMBOL_TYPES_DOMAIN
+This domain contains all types.
+@end vtable
+
+The available address class categories in @code{<gdb:symbol>} are represented
+as constants in the @code{gdb} module:
+
+@vtable @code
+@item SYMBOL_LOC_UNDEF
+If this is returned by address class, it indicates an error either in
+the symbol information or in @value{GDBN}'s handling of symbols.
+
+@item SYMBOL_LOC_CONST
+Value is constant int.
+
+@item SYMBOL_LOC_STATIC
+Value is at a fixed address.
+
+@item SYMBOL_LOC_REGISTER
+Value is in a register.
+
+@item SYMBOL_LOC_ARG
+Value is an argument. This value is at the offset stored within the
+symbol inside the frame's argument list.
+
+@item SYMBOL_LOC_REF_ARG
+Value address is stored in the frame's argument list. Just like
+@code{LOC_ARG} except that the value's address is stored at the
+offset, not the value itself.
+
+@item SYMBOL_LOC_REGPARM_ADDR
+Value is a specified register. Just like @code{LOC_REGISTER} except
+the register holds the address of the argument instead of the argument
+itself.
+
+@item SYMBOL_LOC_LOCAL
+Value is a local variable.
+
+@item SYMBOL_LOC_TYPEDEF
+Value not used. Symbols in the domain @code{SYMBOL_STRUCT_DOMAIN} all
+have this class.
+
+@item SYMBOL_LOC_BLOCK
+Value is a block.
+
+@item SYMBOL_LOC_CONST_BYTES
+Value is a byte-sequence.
+
+@item SYMBOL_LOC_UNRESOLVED
+Value is at a fixed address, but the address of the variable has to be
+determined from the minimal symbol table whenever the variable is
+referenced.
+
+@item SYMBOL_LOC_OPTIMIZED_OUT
+The value does not actually exist in the program.
+
+@item SYMBOL_LOC_COMPUTED
+The value's address is a computed location.
+@end vtable
+
+@node Symbol Tables In Guile
+@subsubsection Symbol table representation in Guile.
+
+@cindex symbol tables in guile
+@tindex <gdb:symtab>
+@tindex <gdb:sal>
+
+Access to symbol table data maintained by @value{GDBN} on the inferior
+is exposed to Guile via two objects: @code{<gdb:sal>} (symtab-and-line) and
+@code{<gdb:symtab>}. Symbol table and line data for a frame is returned
+from the @code{frame-find-sal} @code{<gdb:frame>} procedure.
+@xref{Frames In Guile}.
+
+For more information on @value{GDBN}'s symbol table management, see
+@ref{Symbols, ,Examining the Symbol Table}.
+
+The following symtab-related procedures are provided by the
+@code{(gdb)} module:
+
+@deffn {Scheme Procedure} symtab? object
+Return @code{#t} if @var{object} is an object of type @code{<gdb:symtab>}.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} symtab-valid? symtab
+Return @code{#t} if the @code{<gdb:symtab>} object is valid,
+@code{#f} if not. A @code{<gdb:symtab>} object becomes invalid when
+the symbol table it refers to no longer exists in @value{GDBN}.
+All other @code{<gdb:symtab>} procedures will throw an exception
+if it is invalid at the time the procedure is called.
+@end deffn
+
+@deffn {Scheme Procedure} symtab-filename symtab
+Return the symbol table's source filename.
+@end deffn
+
+@deffn {Scheme Procedure} symtab-fullname symtab
+Return the symbol table's source absolute file name.
+@end deffn
+
+@deffn {Scheme Procedure} symtab-objfile symtab
+Return the symbol table's backing object file. @xref{Objfiles In Guile}.
+@end deffn
+
+@deffn {Scheme Procedure} symtab-global-block symtab
+Return the global block of the underlying symbol table.
+@xref{Blocks In Guile}.
+@end deffn
+
+@deffn {Scheme Procedure} symtab-static-block symtab
+Return the static block of the underlying symbol table.
+@xref{Blocks In Guile}.
+@end deffn
+
+The following symtab-and-line-related procedures are provided by the
+@code{(gdb)} module:
+
+@deffn {Scheme Procedure} sal? object
+Return @code{#t} if @var{object} is an object of type @code{<gdb:sal>}.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} sal-valid? sal
+Return @code{#t} if @var{sal} is valid, @code{#f} if not.
+A @code{<gdb:sal>} object becomes invalid when the Symbol table object
+it refers to no longer exists in @value{GDBN}. All other
+@code{<gdb:sal>} procedures will throw an exception if it is
+invalid at the time the procedure is called.
+@end deffn
+
+@deffn {Scheme Procedure} sal-symtab sal
+Return the symbol table object (@code{<gdb:symtab>}) for @var{sal}.
+@end deffn
+
+@deffn {Scheme Procedure} sal-line sal
+Return the line number for @var{sal}.
+@end deffn
+
+@deffn {Scheme Procedure} sal-pc sal
+Return the start of the address range occupied by code for @var{sal}.
+@end deffn
+
+@deffn {Scheme Procedure} sal-last sal
+Return the end of the address range occupied by code for @var{sal}.
+@end deffn
+
+@deffn {Scheme Procedure} find-pc-line pc
+Return the @code{<gdb:sal>} object corresponding to the @var{pc} value.
+If an invalid value of @var{pc} is passed as an argument, then the
+@code{symtab} and @code{line} attributes of the returned @code{<gdb:sal>}
+object will be @code{#f} and 0 respectively.
+@end deffn
+
+@node Breakpoints In Guile
+@subsubsection Manipulating breakpoints using Guile
+
+@cindex breakpoints in guile
+@tindex <gdb:breakpoint>
+
+Breakpoints in Guile are represented by objects of type
+@code{<gdb:breakpoint>}.
+
+The following breakpoint-related procedures are provided by the
+@code{(gdb)} module:
+
+@c TODO: line length
+@deffn {Scheme Procedure} create-breakpoint! location @r{[}#:type type@r{]} @r{[}#:wp-class wp-class@r{]} @r{[}#:internal internal@r{]}
+Create a new breakpoint. @var{spec} is a string naming the
+location of the breakpoint, or an expression that defines a watchpoint.
+The contents can be any location recognized by the @code{break} command,
+or in the case of a watchpoint, by the @code{watch} command.
+
+The optional @var{type} denotes the breakpoint to create.
+This argument can be either: @code{BP_BREAKPOINT} or @code{BP_WATCHPOINT}.
+@var{type} defaults to @code{BP_BREAKPOINT}.
+
+The optional @var{wp-class} argument defines the class of watchpoint to
+create, if @var{type} is @code{BP_WATCHPOINT}. If a watchpoint class is
+not provided, it is assumed to be a @code{WP_WRITE} class.
+
+The optional @var{internal} argument allows the breakpoint to become
+invisible to the user. The breakpoint will neither be reported when
+created, nor will it be listed in the output from @code{info breakpoints}
+(but will be listed with the @code{maint info breakpoints} command).
+If an internal flag is not provided, the breakpoint is visible
+(non-internal).
+
+When a watchpoint is created, @value{GDBN} will try to create a
+hardware assisted watchpoint. If successful, the type of the watchpoint
+is changed from @code{BP_WATCHPOINT} to @code{BP_HARDWARE_WATCHPOINT}
+for @code{WP_WRITE}, @code{BP_READ_WATCHPOINT} for @code{WP_READ},
+and @code{BP_ACCESS_WATCHPOINT} for @code{WP_ACCESS}.
+If not successful, the type of the watchpoint is left as @code{WP_WATCHPOINT}.
+
+The available types are represented by constants defined in the @code{gdb}
+module:
+
+@vtable @code
+@item BP_BREAKPOINT
+Normal code breakpoint.
+
+@item BP_WATCHPOINT
+Watchpoint breakpoint.
+
+@item BP_HARDWARE_WATCHPOINT
+Hardware assisted watchpoint.
+This value cannot be specified when creating the breakpoint.
+
+@item BP_READ_WATCHPOINT
+Hardware assisted read watchpoint.
+This value cannot be specified when creating the breakpoint.
+
+@item BP_ACCESS_WATCHPOINT
+Hardware assisted access watchpoint.
+This value cannot be specified when creating the breakpoint.
+@end vtable
+
+The available watchpoint types represented by constants are defined in the
+@code{(gdb)} module:
+
+@vtable @code
+@item WP_READ
+Read only watchpoint.
+
+@item WP_WRITE
+Write only watchpoint.
+
+@item WP_ACCESS
+Read/Write watchpoint.
+@end vtable
+
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-delete! breakpoint
+Permanently delete @var{breakpoint}. This also invalidates the
+Guile @var{breakpoint} object. Any further attempt to access the
+object will throw an exception.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoints
+Return a list of all breakpoints.
+Each element of the list is a @code{<gdb:breakpoint>} object.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint? object
+Return @code{#t} if @var{object} is a @code{<gdb:breakpoint>} object,
+and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-valid? breakpoint
+Return @code{#t} if @var{breakpoint} is valid, @code{#f} otherwise.
+A @code{<gdb:breakpoint>} object can become invalid
+if the user deletes the breakpoint. In this case, the object still
+exists, but the underlying breakpoint does not. In the cases of
+watchpoint scope, the watchpoint remains valid even if execution of the
+inferior leaves the scope of that watchpoint.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-number breakpoint
+Return the breakpoint's number --- the identifier used by
+the user to manipulate the breakpoint.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-type breakpoint
+Return the breakpoint's type --- the identifier used to
+determine the actual breakpoint type or use-case.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-visible? breakpoint
+Return @code{#t} if the breakpoint is visible to the user
+when hit, or when the @samp{info breakpoints} command is run.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-location breakpoint
+Return the location of the breakpoint, as specified by
+the user. It is a string. If the breakpoint does not have a location
+(that is, it is a watchpoint) return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-expression breakpoint
+Return the breakpoint expression, as specified by the user. It is a string.
+If the breakpoint does not have an expression (the breakpoint is not a
+watchpoint) return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-enabled? breakpoint
+Return @code{#t} if the breakpoint is enabled, and @code{#f} otherwise.
+@end deffn
+
+@deffn {Scheme Procedure} set-breakpoint-enabled! breakpoint flag
+Set the enabled state of @var{breakpoint} to @var{flag}.
+If flag is @code{#f} it is disabled, otherwise it is enabled.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-silent? breakpoint
+Return @code{#t} if the breakpoint is silent, and @code{#f} otherwise.
+
+Note that a breakpoint can also be silent if it has commands and the
+first command is @code{silent}. This is not reported by the
+@code{silent} attribute.
+@end deffn
+
+@deffn {Scheme Procedure} set-breakpoint-silent! breakpoint flag
+Set the silent state of @var{breakpoint} to @var{flag}.
+If flag is @code{#f} the breakpoint is made silent,
+otherwise it is made non-silent (or noisy).
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-ignore-count breakpoint
+Return the ignore count for @var{breakpoint}.
+@end deffn
+
+@deffn {Scheme Procedure} set-breakpoint-ignore-count! breakpoint count
+Set the ignore count for @var{breakpoint} to @var{count}.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-hit-count breakpoint
+Return hit count of @var{breakpoint}.
+@end deffn
+
+@deffn {Scheme Procedure} set-breakpoint-hit-count! breakpoint count
+Set the hit count of @var{breakpoint} to @var{count}.
+At present, @var{count} must be zero.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-thread breakpoint
+Return the thread-id for thread-specific breakpoint @var{breakpoint}.
+Return #f if @var{breakpoint} is not thread-specific.
+@end deffn
+
+@deffn {Scheme Procedure} set-breakpoint-thread! breakpoint thread-id|#f
+Set the thread-id for @var{breakpoint} to @var{thread-id}.
+If set to @code{#f}, the breakpoint is no longer thread-specific.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-task breakpoint
+If the breakpoint is Ada task-specific, return the Ada task id.
+If the breakpoint is not task-specific (or the underlying
+language is not Ada), return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} set-breakpoint-task! breakpoint task
+Set the Ada task of @var{breakpoint} to @var{task}.
+If set to @code{#f}, the breakpoint is no longer task-specific.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-condition breakpoint
+Return the condition of @var{breakpoint}, as specified by the user.
+It is a string. If there is no condition, return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} set-breakpoint-condition! breakpoint condition
+Set the condition of @var{breakpoint} to @var{condition},
+which must be a string. If set to @code{#f} then the breakpoint
+becomes unconditional.
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-stop breakpoint
+Return the stop predicate of @var{breakpoint}.
+See @code{set-breakpoint-stop!} below in this section.
+@end deffn
+
+@deffn {Scheme Procedure} set-breakpoint-stop! breakpoint procedure|#f
+Set the stop predicate of @var{breakpoint}.
+@var{procedure} takes one argument: the <gdb:breakpoint> object.
+If this predicate is set to a procedure then it is invoked whenever
+the inferior reaches this breakpoint. If it returns @code{#t},
+or any non-@code{#f} value, then the inferior is stopped,
+otherwise the inferior will continue.
+
+If there are multiple breakpoints at the same location with a
+@code{stop} predicate, each one will be called regardless of the
+return status of the previous. This ensures that all @code{stop}
+predicates have a chance to execute at that location. In this scenario
+if one of the methods returns @code{#t} but the others return
+@code{#f}, the inferior will still be stopped.
+
+You should not alter the execution state of the inferior (i.e.@:, step,
+next, etc.), alter the current frame context (i.e.@:, change the current
+active frame), or alter, add or delete any breakpoint. As a general
+rule, you should not alter any data within @value{GDBN} or the inferior
+at this time.
+
+Example @code{stop} implementation:
+
+@smallexample
+(define (my-stop? bkpt)
+ (let ((int-val (parse-and-eval "foo")))
+ (value=? int-val 3)))
+(define bkpt (create-breakpoint! "main.c:42"))
+(set-breakpoint-stop! bkpt my-stop?)
+@end smallexample
+@end deffn
+
+@deffn {Scheme Procedure} breakpoint-commands breakpoint
+Return the commands attached to @var{breakpoint} as a string,
+or @code{#f} if there are none.
+@end deffn
+
+@node Lazy Strings In Guile
+@subsubsection Guile representation of lazy strings.
+
+@cindex lazy strings in guile
+@tindex <gdb:lazy-string>
+
+A @dfn{lazy string} is a string whose contents is not retrieved or
+encoded until it is needed.
+
+A @code{<gdb:lazy-string>} is represented in @value{GDBN} as an
+@code{address} that points to a region of memory, an @code{encoding}
+that will be used to encode that region of memory, and a @code{length}
+to delimit the region of memory that represents the string. The
+difference between a @code{<gdb:lazy-string>} and a string wrapped within
+a @code{<gdb:value>} is that a @code{<gdb:lazy-string>} will be treated
+differently by @value{GDBN} when printing. A @code{<gdb:lazy-string>} is
+retrieved and encoded during printing, while a @code{<gdb:value>}
+wrapping a string is immediately retrieved and encoded on creation.
+
+The following lazy-string-related procedures are provided by the
+@code{(gdb)} module:
+
+@deffn {Scheme Procedure} lazy-string? object
+Return @code{#t} if @var{object} is an object of type @code{<gdb:lazy-string>}.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} lazy-string-address lazy-sring
+Return the address of @var{lazy-string}.
+@end deffn
+
+@deffn {Scheme Procedure} lazy-string-length lazy-string
+Return the length of @var{lazy-string} in characters. If the
+length is -1, then the string will be fetched and encoded up to the
+first null of appropriate width.
+@end deffn
+
+@deffn {Scheme Procedure} lazy-string-encoding lazy-string
+Return the encoding that will be applied to @var{lazy-string}
+when the string is printed by @value{GDBN}. If the encoding is not
+set, or contains an empty string, then @value{GDBN} will select the
+most appropriate encoding when the string is printed.
+@end deffn
+
+@deffn {Scheme Procedure} lazy-string-type lazy-string
+Return the type that is represented by @var{lazy-string}'s type.
+For a lazy string this will always be a pointer type. To
+resolve this to the lazy string's character type, use @code{type-target-type}.
+@xref{Types In Guile}.
+@end deffn
+
+@deffn {Scheme Procedure} lazy-string->value lazy-string
+Convert the @code{<gdb:lazy-string>} to a @code{<gdb:value>}. This value
+will point to the string in memory, but will lose all the delayed
+retrieval, encoding and handling that @value{GDBN} applies to a
+@code{<gdb:lazy-string>}.
+@end deffn
+
+@node Architectures In Guile
+@subsubsection Guile representation of architectures
+
+@cindex guile architectures
+@tindex <gdb:arch>
+
+@value{GDBN} uses architecture specific parameters and artifacts in a
+number of its various computations. An architecture is represented
+by an instance of the @code{<gdb:arch>} class.
+
+The following architecture-related procedures are provided by the
+@code{(gdb)} module:
+
+@deffn {Scheme Procedure} arch? object
+Return @code{#t} if @var{object} is an object of type @code{<gdb:arch>}.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} current-arch
+Return the current architecture as a @code{<gdb:arch>} object.
+@end deffn
+
+@deffn {Scheme Procedure} arch-name arch
+Return the name (string value) of @code{<gdb:arch>} @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-charset arch
+Return name of target character set of @code{<gdb:arch>} @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-wide-charset
+Return name of target wide character set of @code{<gdb:arch>} @var{arch}.
+@end deffn
+
+Each architecture provides a set of predefined types, obtained by
+the following functions.
+
+@deffn {Scheme Procedure} arch-void-type arch
+Return the @code{<gdb:type>} object for a @code{void} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-char-type arch
+Return the @code{<gdb:type>} object for a @code{char} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-short-type arch
+Return the @code{<gdb:type>} object for a @code{short} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-int-type arch
+Return the @code{<gdb:type>} object for an @code{int} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-long-type arch
+Return the @code{<gdb:type>} object for a @code{long} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-schar-type arch
+Return the @code{<gdb:type>} object for a @code{signed char} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-uchar-type arch
+Return the @code{<gdb:type>} object for an @code{unsigned char} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-ushort-type arch
+Return the @code{<gdb:type>} object for an @code{unsigned short} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-uint-type arch
+Return the @code{<gdb:type>} object for an @code{unsigned int} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-ulong-type arch
+Return the @code{<gdb:type>} object for an @code{unsigned long} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-float-type arch
+Return the @code{<gdb:type>} object for a @code{float} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-double-type arch
+Return the @code{<gdb:type>} object for a @code{double} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-longdouble-type arch
+Return the @code{<gdb:type>} object for a @code{long double} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-bool-type arch
+Return the @code{<gdb:type>} object for a @code{bool} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-longlong-type arch
+Return the @code{<gdb:type>} object for a @code{long long} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-ulonglong-type arch
+Return the @code{<gdb:type>} object for an @code{unsigned long long} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-int8-type arch
+Return the @code{<gdb:type>} object for an @code{int8} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-uint8-type arch
+Return the @code{<gdb:type>} object for a @code{uint8} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-int16-type arch
+Return the @code{<gdb:type>} object for an @code{int16} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-uint16-type arch
+Return the @code{<gdb:type>} object for a @code{uint16} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-int32-type arch
+Return the @code{<gdb:type>} object for an @code{int32} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-uint32-type arch
+Return the @code{<gdb:type>} object for a @code{uint32} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-int64-type arch
+Return the @code{<gdb:type>} object for an @code{int64} type
+of architecture @var{arch}.
+@end deffn
+
+@deffn {Scheme Procedure} arch-uint64-type arch
+Return the @code{<gdb:type>} object for a @code{uint64} type
+of architecture @var{arch}.
+@end deffn
+
+Example:
+
+@smallexample
+(gdb) guile (type-name (arch-uchar-type (current-arch)))
+"unsigned char"
+@end smallexample
+
+@node Disassembly In Guile
+@subsubsection Disassembly In Guile
+
+The disassembler can be invoked from Scheme code.
+Furthermore, the disassembler can take a Guile port as input,
+allowing one to disassemble from any source, and not just target memory.
+
+@c TODO: line length
+@deffn {Scheme Procedure} arch-disassemble arch start-pc @r{[}#:port port@r{]} @r{[}#:offset offset@r{]} @r{[}#:size size@r{]} @r{[}#:count count@r{]})
+Return a list of disassembled instructions starting from the memory
+address @var{start-pc}.
+
+The optional argument @var{port} specifies the input port to read bytes from.
+If @var{port} is @code{#f} then bytes are read from target memory.
+
+The optional argument @var{offset} specifies the address offset of the
+first byte in @var{port}. This is useful, for example, when @var{port}
+specifies a @samp{bytevector} and you want the bytevector to be disassembled
+as if it came from that address. The @var{start-pc} passed to the reader
+for @var{port} is offset by the same amount.
+
+Example:
+@smallexample
+(gdb) guile (use-modules (rnrs io ports))
+(gdb) guile (define pc (value->integer (parse-and-eval "$pc")))
+(gdb) guile (define mem (open-memory #:start pc))
+(gdb) guile (define bv (get-bytevector-n mem 10))
+(gdb) guile (define bv-port (open-bytevector-input-port bv))
+(gdb) guile (define arch (current-arch))
+(gdb) guile (arch-disassemble arch pc #:port bv-port #:offset pc)
+(((address . 4195516) (asm . "mov $0x4005c8,%edi") (length . 5)))
+@end smallexample
+
+The optional arguments @var{size} and
+@var{count} determine the number of instructions in the returned list.
+If either @var{size} or @var{count} is specified as zero, then
+no instructions are disassembled and an empty list is returned.
+If both the optional arguments @var{size} and @var{count} are
+specified, then a list of at most @var{count} disassembled instructions
+whose start address falls in the closed memory address interval from
+@var{start-pc} to (@var{start-pc} + @var{size} - 1) are returned.
+If @var{size} is not specified, but @var{count} is specified,
+then @var{count} number of instructions starting from the address
+@var{start-pc} are returned. If @var{count} is not specified but
+@var{size} is specified, then all instructions whose start address
+falls in the closed memory address interval from @var{start-pc} to
+(@var{start-pc} + @var{size} - 1) are returned.
+If neither @var{size} nor @var{count} are specified, then a single
+instruction at @var{start-pc} is returned.
+
+Each element of the returned list is an alist (associative list)
+with the following keys:
+
+@table @code
+
+@item address
+The value corresponding to this key is a Guile integer of
+the memory address of the instruction.
+
+@item asm
+The value corresponding to this key is a string value which represents
+the instruction with assembly language mnemonics. The assembly
+language flavor used is the same as that specified by the current CLI
+variable @code{disassembly-flavor}. @xref{Machine Code}.
+
+@item length
+The value corresponding to this key is the length of the instruction in bytes.
+
+@end table
+@end deffn
+
+@node I/O Ports in Guile
+@subsubsection I/O Ports in Guile
+
+@deffn {Scheme Procedure} input-port
+Return @value{GDBN}'s input port as a Guile port object.
+@end deffn
+
+@deffn {Scheme Procedure} output-port
+Return @value{GDBN}'s output port as a Guile port object.
+@end deffn
+
+@deffn {Scheme Procedure} error-port
+Return @value{GDBN}'s error port as a Guile port object.
+@end deffn
+
+@deffn {Scheme Procedure} stdio-port? object
+Return @code{#t} if @var{object} is a @value{GDBN} stdio port.
+Otherwise return @code{#f}.
+@end deffn
+
+@node Memory Ports in Guile
+@subsubsection Memory Ports in Guile
+
+@value{GDBN} provides a @code{port} interface to target memory.
+This allows Guile code to read/write target memory using Guile's port and
+bytevector functionality. The main routine is @code{open-memory} which
+returns a port object. One can then read/write memory using that object.
+
+@deffn {Scheme Procedure} open-memory @r{[}#:mode mode{]} @r{[}#:start address{]} @r{[}#:size size{]}
+Return a port object that can be used for reading and writing memory.
+@var{mode} is the standard mode argument to Guile port open routines,
+except that it is restricted to one of @samp{"r"}, @samp{"w"}, or @samp{"r+"}.
+For compatibility @samp{"b"} (binary) may also be present,
+but we ignore it: memory ports are binary only.
+The default is @samp{"r"}, read-only.
+
+The chunk of memory that can be accessed can be bounded.
+If both @var{start} and @var{size} are unspecified, all of memory can be
+accessed. If only @var{start} is specified, all of memory from that point
+on can be accessed. If only @var{size} if specified, all memory in the
+range [0,@var{size}) can be accessed. If both are specified, all memory
+in the rane [@var{start},@var{start}+@var{size}) can be accessed.
+@end deffn
+
+@deffn {Scheme Procedure} memory-port?
+Return @code{#t} if @var{object} is an object of type @code{<gdb:memory-port>}.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} memory-port-range memory-port
+Return the range of @code{<gdb:memory-port>} @var{memory-port} as a list
+of two elements: @code{(start end)}. The range is @var{start} to @var{end}
+inclusive.
+@end deffn
+
+@deffn {Scheme Procedure} memory-port-read-buffer-size memory-port
+Return the size of the read buffer of @code{<gdb:memory-port>}
+@var{memory-port}.
+@end deffn
+
+@deffn {Scheme Procedure} set-memory-port-read-buffer-size! memory-port size
+Set the size of the read buffer of @code{<gdb:memory-port>}
+@var{memory-port} to @var{size}. The result is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} memory-port-write-buffer-size memory-port
+Return the size of the write buffer of @code{<gdb:memory-port>}
+@var{memory-port}.
+@end deffn
+
+@deffn {Scheme Procedure} set-memory-port-write-buffer-size! memory-port size
+Set the size of the write buffer of @code{<gdb:memory-port>}
+@var{memory-port} to @var{size}. The result is unspecified.
+@end deffn
+
+A memory port is closed like any other port, with @code{close-port}.
+
+Combined with Guile's @code{bytevectors}, memory ports provide a lot
+of utility. For example, to fill a buffer of 10 integers in memory,
+one can do something like the following.
+
+@smallexample
+;; In the program: int buffer[10];
+(use-modules (rnrs bytevectors))
+(use-modules (rnrs io ports))
+(define addr (parse-and-eval "buffer"))
+(define n 10)
+(define byte-size (* n 4))
+(define mem-port (open-memory #:mode "r+" #:start
+ (value->integer addr) #:size byte-size))
+(define byte-vec (make-bytevector byte-size))
+(do ((i 0 (+ i 1)))
+ ((>= i n))
+ (bytevector-s32-native-set! byte-vec (* i 4) (* i 42)))
+(put-bytevector mem-port byte-vec)
+(close-port mem-port)
+@end smallexample
+
+@node Iterators In Guile
+@subsubsection Iterators In Guile
+
+@cindex guile iterators
+@tindex <gdb:iterator>
+
+A simple iterator facility is provided to allow, for example,
+iterating over the set of program symbols without having to first
+construct a list of all of them. A useful contribution would be
+to add support for SRFI 41 and SRFI 45.
+
+@deffn {Scheme Procedure} make-iterator object progress next!
+A @code{<gdb:iterator>} object is constructed with the @code{make-iterator}
+procedure. It takes three arguments: the object to be iterated over,
+an object to record the progress of the iteration, and a procedure to
+return the next element in the iteration, or an implementation chosen value
+to denote the end of iteration.
+
+By convention, end of iteration is marked with @code{(end-of-iteration)},
+and may be tested with the @code{end-of-iteration?} predicate.
+The result of @code{(end-of-iteration)} is chosen so that it is not
+otherwise used by the @code{(gdb)} module. If you are using
+@code{<gdb:iterator>} in your own code it is your responsibility to
+maintain this invariant.
+
+A trivial example for illustration's sake:
+
+@smallexample
+(use-modules (gdb iterator))
+(define my-list (list 1 2 3))
+(define iter
+ (make-iterator my-list my-list
+ (lambda (iter)
+ (let ((l (iterator-progress iter)))
+ (if (eq? l '())
+ (end-of-iteration)
+ (begin
+ (set-iterator-progress! iter (cdr l))
+ (car l)))))))
+@end smallexample
+
+Here is a slightly more realistic example, which computes a list of all the
+functions in @code{my-global-block}.
+
+@smallexample
+(use-modules (gdb iterator))
+(define this-sal (find-pc-line (frame-pc (selected-frame))))
+(define this-symtab (sal-symtab this-sal))
+(define this-global-block (symtab-global-block this-symtab))
+(define syms-iter (make-block-symbols-iterator this-global-block))
+(define functions (iterator-filter symbol-function? syms-iter))
+@end smallexample
+@end deffn
+
+@deffn {Scheme Procedure} iterator? object
+Return @code{#t} if @var{object} is a @code{<gdb:iterator>} object.
+Otherwise return @code{#f}.
+@end deffn
+
+@deffn {Scheme Procedure} iterator-object iterator
+Return the first argument that was passed to @code{make-iterator}.
+This is the object being iterated over.
+@end deffn
+
+@deffn {Scheme Procedure} iterator-progress iterator
+Return the object tracking iteration progress.
+@end deffn
+
+@deffn {Scheme Procedure} set-iterator-progress! iterator new-value
+Set the object tracking iteration progress.
+@end deffn
+
+@deffn {Scheme Procedure} iterator-next! iterator
+Invoke the procedure that was the third argument to @code{make-iterator},
+passing it one argument, the @code{<gdb:iterator>} object.
+The result is either the next element in the iteration, or an end
+marker as implemented by the @code{next!} procedure.
+By convention the end marker is the result of @code{(end-of-iteration)}.
+@end deffn
+
+@deffn {Scheme Procedure} end-of-iteration
+Return the Scheme object that denotes end of iteration.
+@end deffn
+
+@deffn {Scheme Procedure} end-of-iteration? object
+Return @code{#t} if @var{object} is the end of iteration marker.
+Otherwise return @code{#f}.
+@end deffn
+
+These functions are provided by the @code{(gdb iterator)} module to
+assist in using iterators.
+
+@deffn {Scheme Procedure} make-list-iterator list
+Return a @code{<gdb:iterator>} object that will iterate over @var{list}.
+@end deffn
+
+@deffn {Scheme Procedure} iterator->list iterator
+Return the elements pointed to by @var{iterator} as a list.
+@end deffn
+
+@deffn {Scheme Procedure} iterator-map proc iterator
+Return the list of objects obtained by applying @var{proc} to the object
+pointed to by @var{iterator} and to each subsequent object.
+@end deffn
+
+@deffn {Scheme Procedure} iterator-for-each proc iterator
+Apply @var{proc} to each element pointed to by @var{iterator}.
+The result is unspecified.
+@end deffn
+
+@deffn {Scheme Procedure} iterator-filter pred iterator
+Return the list of elements pointed to by @var{iterator} that satisfy
+@var{pred}.
+@end deffn
+
+@deffn {Scheme Procedure} iterator-until pred iterator
+Run @var{iterator} until the result of @code{(pred element)} is true
+and return that as the result. Otherwise return @code{#f}.
+@end deffn
+
+@node Guile Auto-loading
+@subsection Guile Auto-loading
+@cindex guile auto-loading
+
+When a new object file is read (for example, due to the @code{file}
+command, or because the inferior has loaded a shared library),
+@value{GDBN} will look for Guile support scripts in two ways:
+@file{@var{objfile}-gdb.scm} and the @code{.debug_gdb_scripts} section.
+@xref{Auto-loading extensions}.
+
+The auto-loading feature is useful for supplying application-specific
+debugging commands and scripts.
+
+Auto-loading can be enabled or disabled,
+and the list of auto-loaded scripts can be printed.
+
+@table @code
+@anchor{set auto-load guile-scripts}
+@kindex set auto-load guile-scripts
+@item set auto-load guile-scripts [on|off]
+Enable or disable the auto-loading of Guile scripts.
+
+@anchor{show auto-load guile-scripts}
+@kindex show auto-load guile-scripts
+@item show auto-load guile-scripts
+Show whether auto-loading of Guile scripts is enabled or disabled.
+
+@anchor{info auto-load guile-scripts}
+@kindex info auto-load guile-scripts
+@cindex print list of auto-loaded Guile scripts
+@item info auto-load guile-scripts [@var{regexp}]
+Print the list of all Guile scripts that @value{GDBN} auto-loaded.
+
+Also printed is the list of Guile scripts that were mentioned in
+the @code{.debug_gdb_scripts} section and were not found.
+This is useful because their names are not printed when @value{GDBN}
+tries to load them and fails. There may be many of them, and printing
+an error message for each one is problematic.
+
+If @var{regexp} is supplied only Guile scripts with matching names are printed.
+
+Example:
+
+@smallexample
+(gdb) info auto-load guile-scripts
+Loaded Script
+Yes scm-section-script.scm
+ full name: /tmp/scm-section-script.scm
+No my-foo-pretty-printers.scm
+@end smallexample
+@end table
+
+When reading an auto-loaded file, @value{GDBN} sets the
+@dfn{current objfile}. This is available via the @code{current-objfile}
+procedure (@pxref{Objfiles In Guile}). This can be useful for
+registering objfile-specific pretty-printers.
+
+@node Guile Modules
+@subsection Guile Modules
+@cindex guile modules
+
+@value{GDBN} comes with several modules to assist writing Guile code.
+
+@menu
+* Guile Printing Module:: Building and registering pretty-printers
+* Guile Types Module:: Utilities for working with types
+@end menu
+
+@node Guile Printing Module
+@subsubsection Guile Printing Module
+
+This module provides a collection of utilities for working with
+pretty-printers.
+
+Usage:
+
+@smallexample
+(use-modules (gdb printing))
+@end smallexample
+
+@deffn {Scheme Procedure} prepend-pretty-printer! object printer
+Add @var{printer} to the front of the list of pretty-printers for
+@var{object}. @var{object} must either be a @code{<gdb:objfile>} object
+or @code{#f} in which case @var{printer} is added to the global list of
+printers.
+@end deffn
+
+@deffn {Scheme Procecure} append-pretty-printer! object printer
+Add @var{printer} to the end of the list of pretty-printers for
+@var{object}. @var{object} must either be a @code{<gdb:objfile>} object
+or @code{#f} in which case @var{printer} is added to the global list of
+printers.
+@end deffn
+
+@node Guile Types Module
+@subsubsection Guile Types Module
+
+This module provides a collection of utilities for working with
+@code{<gdb:type>} objects.
+
+Usage:
+
+@smallexample
+(use-modules (gdb types))
+@end smallexample
+
+@deffn {Scheme Procedure} get-basic-type type
+Return @var{type} with const and volatile qualifiers stripped,
+and with typedefs and C@t{++} references converted to the underlying type.
+
+C@t{++} example:
+
+@smallexample
+typedef const int const_int;
+const_int foo (3);
+const_int& foo_ref (foo);
+int main () @{ return 0; @}
+@end smallexample
+
+Then in gdb:
+
+@smallexample
+(gdb) start
+(gdb) guile (use-modules ((gdb) (gdb types)))
+(gdb) guile (define foo-ref (parse-and-eval "foo_ref"))
+(gdb) guile (get-basic-type (value-type foo-ref))
+int
+@end smallexample
+@end deffn
+
+@deffn {Scheme Procedure} type-has-field-deep? type field
+Return @code{#t} if @var{type}, assumed to be a type with fields
+(e.g., a structure or union), has field @var{field}.
+Otherwise return @code{#f}.
+This searches baseclasses, whereas @code{type-has-field?} does not.
+@end deffn
+
+@deffn {Scheme Procedure} make-enum-hashtable enum-type
+Return a Guile hash table produced from @var{enum-type}.
+Elements in the hash table are referenced with @code{hashq-ref}.
+@end deffn
#include "observer.h"
#include "cli/cli-script.h"
#include "python/python.h"
+#include "guile/guile.h"
/* Iterate over all external extension languages, regardless of whether the
support has been compiled in or not.
{
/* To preserve existing behaviour, python should always appear first. */
&extension_language_python,
+ &extension_language_guile,
NULL
};
{
EXT_LANG_NONE,
EXT_LANG_GDB,
- EXT_LANG_PYTHON
+ EXT_LANG_PYTHON,
+ EXT_LANG_GUILE
};
/* Extension language frame-filter status return values. */
error (_("Type %s has no component named %s."), typename, name);
}
+/* Store in *MAX the largest number representable by unsigned integer type
+ TYPE. */
+
+void
+get_unsigned_type_max (struct type *type, ULONGEST *max)
+{
+ unsigned int n;
+
+ CHECK_TYPEDEF (type);
+ gdb_assert (TYPE_CODE (type) == TYPE_CODE_INT && TYPE_UNSIGNED (type));
+ gdb_assert (TYPE_LENGTH (type) <= sizeof (ULONGEST));
+
+ /* Written this way to avoid overflow. */
+ n = TYPE_LENGTH (type) * TARGET_CHAR_BIT;
+ *max = ((((ULONGEST) 1 << (n - 1)) - 1) << 1) | 1;
+}
+
+/* Store in *MIN, *MAX the smallest and largest numbers representable by
+ signed integer type TYPE. */
+
+void
+get_signed_type_minmax (struct type *type, LONGEST *min, LONGEST *max)
+{
+ unsigned int n;
+
+ CHECK_TYPEDEF (type);
+ gdb_assert (TYPE_CODE (type) == TYPE_CODE_INT && !TYPE_UNSIGNED (type));
+ gdb_assert (TYPE_LENGTH (type) <= sizeof (LONGEST));
+
+ n = TYPE_LENGTH (type) * TARGET_CHAR_BIT;
+ *min = -((ULONGEST) 1 << (n - 1));
+ *max = ((ULONGEST) 1 << (n - 1)) - 1;
+}
+
/* Lookup the vptr basetype/fieldno values for TYPE.
If found store vptr_basetype in *BASETYPEP if non-NULL, and return
vptr_fieldno. Also, if found and basetype is from the same objfile,
extern struct type *lookup_signed_typename (const struct language_defn *,
struct gdbarch *, const char *);
+extern void get_unsigned_type_max (struct type *, ULONGEST *);
+
+extern void get_signed_type_minmax (struct type *, LONGEST *, LONGEST *);
+
extern struct type *check_typedef (struct type *);
#define CHECK_TYPEDEF(TYPE) \
--- /dev/null
+README for gdb/guile
+====================
+
+This file contains important notes for gdb/guile developers.
+["gdb/guile" refers to the directory you found this file in]
+
+Nomenclature:
+
+ In the implementation we use "Scheme" or "Guile" depending on context.
+ And sometimes it doesn't matter.
+ Guile is Scheme, and for the most part this is what we present to the user
+ as well. However, to highlight the fact that it is Guile, the GDB commands
+ that invoke Scheme functions are named "guile" and "guile-repl",
+ abbreviated "gu" and "gr" respectively.
+
+Co-existence with Python:
+
+ Keep the user interfaces reasonably consistent, but don't shy away from
+ providing a clearer (or more Scheme-friendly/consistent) user interface
+ where appropriate.
+
+ Additions to Python support or Scheme support don't require corresponding
+ changes in the other scripting language.
+
+ Scheme-wrapped breakpoints are created lazily so that if the user
+ doesn't use Scheme s/he doesn't pay any cost.
+
+Importing the gdb module into Scheme:
+
+ To import the gdb module:
+ (gdb) guile (use-modules (gdb))
+
+ If you want to add a prefix to gdb module symbols:
+ (gdb) guile (use-modules ((gdb) #:renamer (symbol-prefix-proc 'gdb:)))
+ This gives every symbol a "gdb:" prefix which is a common convention.
+ OTOH it's more to type.
+
+Implementation/Hacking notes:
+
+ Don't use scm_is_false.
+ For this C function, () == #f (a la Lisp) and it's not clear how treating
+ them as equivalent for truth values will affect the GDB interface.
+ Until the effect is clear avoid them.
+ Instead use gdbscm_is_false, gdbscm_is_true, gdbscm_is_bool.
+ There are macros in guile-internal.h to enforce this.
+
+ Use gdbscm_foo as the name of functions that implement Scheme procedures
+ to provide consistent naming in error messages. The user can see "gdbscm"
+ in the name and immediately know where the function came from.
+
+ All smobs contain gdb_smob or chained_gdb_smob as the first member.
+ This provides a mechanism for extending them in the Scheme side without
+ tying GDB to the details.
+
+ The lifetime of a smob, AIUI, is decided by the containing SCM.
+ When there is no longer a reference to the containing SCM then the
+ smob can be GC'd. Objects that have references from outside of Scheme,
+ e.g., breakpoints, need to be protected from GC.
+
+ Don't do something that can cause a Scheme exception inside a TRY_CATCH,
+ and, in code that can be called from Scheme, don't do something that can
+ cause a GDB exception outside a TRY_CATCH.
+ This makes the code a little tricky to write sometimes, but it is a
+ rule imposed by the programming environment. Bugs often happen because
+ this rule is broken. Learn it, follow it.
+\f
+Coding style notes:
+
+ - If you find violations to these rules, let's fix the code.
+ Some attempt has been made to be consistent, but it's early.
+ Over time we want things to be more consistent, not less.
+
+ - None of this really needs to be read. Instead, do not be creative:
+ Monkey-See-Monkey-Do hacking should generally Just Work.
+
+ - Absence of the word "typically" means the rule is reasonably strict.
+
+ - The gdbscm_initialize_foo function (e.g., gdbscm_initialize_values)
+ is the last thing to appear in the file, immediately preceded by any
+ tables of exported variables and functions.
+
+ - In addition to these of course, follow GDB coding conventions.
+
+General naming rules:
+
+ - The word "object" absent any modifier (like "GOOPS object") means a
+ Scheme object (of any type), and is never used otherwise.
+ If you want to refer to, e.g., a GOOPS object, say "GOOPS object".
+
+ - Do not begin any function, global variable, etc. name with scm_.
+ That's what the Guile implementation uses.
+ (kinda obvious, just being complete).
+
+ - The word "invalid" carries a specific connotation. Try not to use it
+ in a different way. It means the underlying GDB object has disappeared.
+ For example, a <gdb:objfile> smob becomes "invalid" when the underlying
+ objfile is removed from GDB.
+
+ - We typically use the word "exception" to mean Scheme exceptions,
+ and we typically use the word "error" to mean GDB errors.
+
+Comments:
+
+ - function comments for functions implementing Scheme procedures begin with
+ a description of the Scheme usage. Example:
+ /* (gsmob-aux gsmob) -> object */
+
+ - the following comment appears after the copyright header:
+ /* See README file in this directory for implementation notes, coding
+ conventions, et.al. */
+
+Smob naming:
+
+ - gdb smobs are named, internally, "gdb:foo"
+ - in Guile they become <gdb:foo>, that is the convention for naming classes
+ and smobs have rudimentary GOOPS support (they can't be inherited from,
+ but generics can work with them)
+ - in comments use the Guile naming for smobs,
+ i.e., <gdb:foo> instead of gdb:foo.
+ Note: This only applies to smobs. Exceptions are also named gdb:foo,
+ but since they are not "classes" they are not wrapped in <>.
+ - smob names are stored in a global, and for simplicity we pass this
+ global as the "expected type" parameter to SCM_ASSERT_TYPE, thus in
+ this instance smob types are printed without the <>.
+ [Hmmm, this rule seems dated now. Plus I18N rules in GDB are not always
+ clear, sometimes we pass the smob name through _(), however it's not
+ clear that's actually a good idea.]
+
+Type naming:
+
+ - smob structs are typedefs named foo_smob
+
+Variable naming:
+
+ - "scm" by itself is reserved for arbitrary Scheme objects
+
+ - variables that are pointers to smob structs are named <char>_smob or
+ <char><char>_smob, e.g., f_smob for a pointer to a frame smob
+
+ - variables that are gdb smob objects are typically named <char>_scm or
+ <char><char>_scm, e.g., f_scm for a <gdb:frame> object
+
+ - the name of the first argument for method-like functions is "self"
+
+Function naming:
+
+ General:
+
+ - all non-static functions have a prefix,
+ either gdbscm_ or <char><char>scm_ [or <char><char><char>scm_]
+
+ - all functions that implement Scheme procedures have a gdbscm_ prefix,
+ this is for consistency and readability of Scheme exception text
+
+ - static functions typically have a prefix
+ - the prefix is typically <char><char>scm_ where the first two letters
+ are unique to the file or class the function works with.
+ E.g., the scm-arch.c prefix is arscm_.
+ This follows something used in gdb/python in some places,
+ we make it formal.
+
+ - if the function is of a general nature, or no other prefix works,
+ use gdbscm_
+
+ Conversion functions:
+
+ - the from/to in function names follows from libguile's existing style
+ - conversions from/to Scheme objects are named:
+ prefix_scm_from_foo: converts from foo to scm
+ prefix_scm_to_foo: converts from scm to foo
+
+ Exception handling:
+
+ - functions that may throw a Scheme exception have an _unsafe suffix
+ - This does not apply to functions that implement Scheme procedures.
+ - This does not apply to functions whose explicit job is to throw
+ an exception. Adding _unsafe to gdbscm_throw is kinda superfluous. :-)
+ - functions that can throw a GDB error aren't adorned with _unsafe
+
+ - "_safe" in a function name means it will never throw an exception
+ - Generally unnecessary, since the convention is to mark the ones that
+ *can* throw an exception. But sometimes it's useful to highlight the
+ fact that the function is safe to call without worrying about exception
+ handling.
+
+ - except for functions that implement Scheme procedures, all functions
+ that can throw exceptions (GDB or Scheme) say so in their function comment
+
+ - functions that don't throw an exception, but still need to indicate to
+ the caller that one happened (i.e., "safe" functions), either return
+ a <gdb:exception> smob as a result or pass it back via a parameter.
+ For this reason don't pass back <gdb:exception> smobs for any other
+ reason. There are functions that explicitly construct <gdb:exception>
+ smobs. They're obviously the, umm, exception.
+
+ Internal functions:
+
+ - internal Scheme functions begin with "%" and are intentionally undocumented
+ in the manual
+
+ Standard Guile/Scheme conventions:
+
+ - predicates that return Scheme values have the suffix _p and have suffix "?"
+ in the Scheme procedure's name
+ - functions that implement Scheme procedures that modify state have the
+ suffix _x and have suffix "!" in the Scheme procedure's name
+ - object predicates that return a C truth value are named prefix_is_foo
+ - functions that set something have "set" at the front (except for a prefix)
+ write this: gdbscm_set_gsmob_aux_x implements (set-gsmob-aux! ...)
+ not this: gdbscm_gsmob_set_aux_x implements (gsmob-set-aux! ...)
+
+Doc strings:
+
+ - there are lots of existing examples, they should be pretty consistent,
+ use them as boilerplate/examples
+ - begin with a one line summary (can be multiple lines if necessary)
+ - if the arguments need description:
+ - blank line
+ - " Arguments: arg1 arg2"
+ " arg1: blah ..."
+ " arg2: blah ..."
+ - if the result requires more description:
+ - blank line
+ - " Returns:"
+ " Blah ..."
+ - if it's important to list exceptions that can be thrown:
+ - blank line
+ - " Throws:"
+ " exception-name: blah ..."
--- /dev/null
+/* Internal header for GDB/Scheme code.
+
+ Copyright (C) 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. */
+
+#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;
+\f
+/* 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 void gdbscm_dynwind_xfree (void *ptr);
+
+extern int gdbscm_is_procedure (SCM proc);
+\f
+/* 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 \
+ /* Property list for externally added fields. */ \
+ SCM properties;
+
+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 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);
+\f
+/* 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_with_stack (SCM port, SCM stack,
+ SCM key, SCM args);
+
+extern void gdbscm_print_gdb_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);
+\f
+/* 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 (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 gdbscm_end_of_iteration (void);
+
+extern int itscm_is_end_of_iteration (SCM obj);
+
+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_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 (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 SCM gdbscm_scm_from_string (const char *string, size_t len,
+ const char *charset, int strict);
+
+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_scm_from_symbol (struct symbol *symbol);
+
+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 (struct symtab *symtab);
+
+extern SCM stscm_scm_from_sal (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 (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_scm_from_field (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 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);
+\f
+/* 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);
+\f
+/* 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);
+\f
+/* 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 */
--- /dev/null
+/* General GDB/Guile code.
+
+ Copyright (C) 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 <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
+};
+\f
+#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-repl" command. */
+
+static void
+guile_repl_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-repl 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);
+ }
+}
+\f
+/* (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-repl" and "guile"
+ commands. */
+
+static void
+guile_repl_command (char *arg, int from_tty)
+{
+ arg = skip_spaces (arg);
+ if (arg && *arg)
+ error (_("guile-repl 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 */
+\f
+/* 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);
+}
+\f
+/* 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 = scm_from_latin1_symbol ("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-repl", class_obscure,
+ guile_repl_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) or ,quit.")
+#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 ("gr", "guile-repl", 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 one or more Guile expressions.\n\
+\n\
+The expression(s) can be given as an argument, for instance:\n\
+\n\
+ guile (display 23)\n\
+\n\
+The result of evaluating the last expression is printed.\n\
+\n\
+If no argument is given, the following lines are read and passed\n\
+to Guile for evaluation. Type a line containing \"end\" to indicate\n\
+the end of the set of expressions.\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-repl\"\n\
+command, provides extensive help and apropos capabilities.\n\
+Type \",help\" once in a Guile interactive session.")
+#else /* HAVE_GUILE */
+ _("\
+Evaluate a Guile expression.\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
+}
--- /dev/null
+/* General GDB/Scheme code.
+
+ Copyright (C) 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/>. */
+
+#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 */
--- /dev/null
+;; Scheme side of the gdb module.
+;;
+;; Copyright (C) 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/>.
+
+;; This file is loaded with scm_c_primitive_load, which is ok, but files
+;; loaded with it are not compiled. So we do very little here, and do
+;; most of the initialization in init.scm.
+
+(define-module (gdb)
+ ;; The version of the (gdb) module as (major minor).
+ ;; Incompatible changes bump the major version.
+ ;; Other changes bump the minor version.
+ ;; It's not clear whether we need a patch-level as well, but this can
+ ;; be added later if necessary.
+ ;; This is not the GDB version on purpose. This version tracks the Scheme
+ ;; gdb module version.
+ ;; TODO: Change to (1 0) when ready.
+ #:version (0 1))
+
+;; Export the bits provided by the C side.
+;; This is so that the compiler can see the exports when
+;; other code uses this module.
+;; TODO: Generating this list would be nice, but it would require an addition
+;; to the GDB build system. Still, I think it's worth it.
+
+(export
+
+ ;; guile.c
+
+ execute
+ data-directory
+ gdb-version
+ host-config
+ target-config
+
+ ;; scm-arch.c
+
+ arch?
+ current-arch
+ arch-name
+ arch-charset
+ arch-wide-charset
+
+ arch-void-type
+ arch-char-type
+ arch-short-type
+ arch-int-type
+ arch-long-type
+
+ arch-schar-type
+ arch-uchar-type
+ arch-ushort-type
+ arch-uint-type
+ arch-ulong-type
+ arch-float-type
+ arch-double-type
+ arch-longdouble-type
+ arch-bool-type
+ arch-longlong-type
+ arch-ulonglong-type
+
+ arch-int8-type
+ arch-uint8-type
+ arch-int16-type
+ arch-uint16-type
+ arch-int32-type
+ arch-uint32-type
+ arch-int64-type
+ arch-uint64-type
+
+ ;; scm-block.c
+
+ block?
+ block-valid?
+ block-start
+ block-end
+ block-function
+ block-superblock
+ block-global-block
+ block-static-block
+ block-global?
+ block-static?
+ block-symbols
+ make-block-symbols-iterator
+ block-symbols-progress?
+ lookup-block
+
+ ;; scm-breakpoint.c
+
+ BP_NONE
+ BP_BREAKPOINT
+ BP_WATCHPOINT
+ BP_HARDWARE_WATCHPOINT
+ BP_READ_WATCHPOINT
+ BP_ACCESS_WATCHPOINT
+
+ WP_READ
+ WP_WRITE
+ WP_ACCESS
+
+ make-breakpoint
+ breakpoint-delete!
+ breakpoints
+ breakpoint?
+ breakpoint-valid?
+ breakpoint-number
+ breakpoint-type
+ brekapoint-visible?
+ breakpoint-location
+ breakpoint-expression
+ breakpoint-enabled?
+ set-breakpoint-enabled!
+ breakpoint-silent?
+ set-breakpoint-silent!
+ breakpoint-ignore-count
+ set-breakpoint-ignore-count!
+ breakpoint-hit-count
+ set-breakpoint-hit-count!
+ breakpoint-thread
+ set-breakpoint-thread!
+ breakpoint-task
+ set-breakpoint-task!
+ breakpoint-condition
+ set-breakpoint-condition!
+ breakpoint-stop
+ set-breakpoint-stop!
+ breakpoint-commands
+
+ ;; scm-disasm.c
+
+ arch-disassemble
+
+ ;; scm-exception.c
+
+ make-exception
+ exception?
+ exception-key
+ exception-args
+
+ ;; scm-frame.c
+
+ NORMAL_FRAME
+ DUMMY_FRAME
+ INLINE_FRAME
+ TAILCALL_FRAME
+ SIGTRAMP_FRAME
+ ARCH_FRAME
+ SENTINEL_FRAME
+
+ FRAME_UNWIND_NO_REASON
+ FRAME_UNWIND_NULL_ID
+ FRAME_UNWIND_OUTERMOST
+ FRAME_UNWIND_UNAVAILABLE
+ FRAME_UNWIND_INNER_ID
+ FRAME_UNWIND_SAME_ID
+ FRAME_UNWIND_NO_SAVED_PC
+
+ frame?
+ frame-valid?
+ frame-name
+ frame-type
+ frame-arch
+ frame-unwind-stop-reason
+ frame-pc
+ frame-block
+ frame-function
+ frame-older
+ frame-newer
+ frame-sal
+ frame-read-var
+ frame-select
+ newest-frame
+ selected-frame
+ unwind-stop-reason-string
+
+ ;; scm-iterator.c
+
+ make-iterator
+ iterator?
+ iterator-object
+ iterator-progress
+ set-iterator-progress!
+ iterator-next!
+ end-of-iteration
+ end-of-iteration?
+
+ ;; scm-lazy-string.c
+ ;; FIXME: Where's the constructor?
+
+ lazy-string?
+ lazy-string-address
+ lazy-string-length
+ lazy-string-encoding
+ lazy-string-type
+ lazy-string->value
+
+ ;; scm-math.c
+
+ valid-add
+ value-sub
+ value-mul
+ value-div
+ value-rem
+ value-mod
+ value-pow
+ value-not
+ value-neg
+ value-pos
+ value-abs
+ value-lsh
+ value-rsh
+ value-min
+ value-max
+ value-lognot
+ value-logand
+ value-logior
+ value-logxor
+ value=?
+ value<?
+ value<=?
+ value>?
+ value>=?
+
+ ;; scm-objfile.c
+
+ objfile?
+ objfile-valid?
+ objfile-filename
+ objfile-pretty-printers
+ set-objfile-pretty-printers!
+ current-objfile
+ objfiles
+
+ ;; scm-ports.c
+
+ input-port
+ output-port
+ error-port
+ stdio-port?
+ open-memory
+ memory-port?
+ memory-port-range
+ memory-port-read-buffer-size
+ set-memory-port-read-buffer-size!
+ memory-port-write-buffer-size
+ set-memory-port-write-buffer-size!
+ ;; with-gdb-output-to-port, with-gdb-error-to-port are in experimental.scm.
+
+ ;; scm-pretty-print.c
+
+ make-pretty-printer
+ pretty-printer?
+ pretty-printer-enabled?
+ set-pretty-printer-enabled!
+ make-pretty-printer-worker
+ pretty-printer-worker?
+
+ ;; scm-smob.c
+
+ gsmob-kind
+ gsmob-property
+ set-gsmob-property!
+ gsmob-has-property?
+ gsmob-properties
+
+ ;; scm-string.c
+
+ string->argv
+
+ ;; scm-symbol.c
+
+ SYMBOL_LOC_UNDEF
+ SYMBOL_LOC_CONST
+ SYMBOL_LOC_STATIC
+ SYMBOL_LOC_REGISTER
+ SYMBOL_LOC_ARG
+ SYMBOL_LOC_REF_ARG
+ SYMBOL_LOC_LOCAL
+ SYMBOL_LOC_TYPEDEF
+ SYMBOL_LOC_LABEL
+ SYMBOL_LOC_BLOCK
+ SYMBOL_LOC_CONST_BYTES
+ SYMBOL_LOC_UNRESOLVED
+ SYMBOL_LOC_OPTIMIZED_OUT
+ SYMBOL_LOC_COMPUTED
+ SYMBOL_LOC_REGPARM_ADDR
+
+ SYMBOL_UNDEF_DOMAIN
+ SYMBOL_VAR_DOMAIN
+ SYMBOL_STRUCT_DOMAIN
+ SYMBOL_LABEL_DOMAIN
+ SYMBOL_VARIABLES_DOMAIN
+ SYMBOL_FUNCTIONS_DOMAIN
+ SYMBOL_TYPES_DOMAIN
+
+ symbol?
+ symbol-valid?
+ symbol-type
+ symbol-symtab
+ symbol-line
+ symbol-name
+ symbol-linkage-name
+ symbol-print-name
+ symbol-addr-class
+ symbol-argument?
+ symbol-constant?
+ symbol-function?
+ symbol-variable?
+ symbol-needs-frame?
+ symbol-value
+ lookup-symbol
+ lookup-global-symbol
+
+ ;; scm-symtab.c
+
+ symtab?
+ symtab-valid?
+ symtab-filename
+ symtab-fullname
+ symtab-objfile
+ symtab-global-block
+ symtab-static-block
+ sal?
+ sal-valid?
+ sal-symtab
+ sal-line
+ sal-pc
+ sal-last
+ find-pc-line
+
+ ;; scm-type.c
+
+ TYPE_CODE_BITSTRING
+ TYPE_CODE_PTR
+ TYPE_CODE_ARRAY
+ TYPE_CODE_STRUCT
+ TYPE_CODE_UNION
+ TYPE_CODE_ENUM
+ TYPE_CODE_FLAGS
+ TYPE_CODE_FUNC
+ TYPE_CODE_INT
+ TYPE_CODE_FLT
+ TYPE_CODE_VOID
+ TYPE_CODE_SET
+ TYPE_CODE_RANGE
+ TYPE_CODE_STRING
+ TYPE_CODE_ERROR
+ TYPE_CODE_METHOD
+ TYPE_CODE_METHODPTR
+ TYPE_CODE_MEMBERPTR
+ TYPE_CODE_REF
+ TYPE_CODE_CHAR
+ TYPE_CODE_BOOL
+ TYPE_CODE_COMPLEX
+ TYPE_CODE_TYPEDEF
+ TYPE_CODE_NAMESPACE
+ TYPE_CODE_DECFLOAT
+ TYPE_CODE_INTERNAL_FUNCTION
+
+ type?
+ lookup-type
+ type-code
+ type-fields
+ type-tag
+ type-sizeof
+ type-strip-typedefs
+ type-array
+ type-vector
+ type-pointer
+ type-range
+ type-reference
+ type-target
+ type-const
+ type-volatile
+ type-unqualified
+ type-name
+ type-num-fields
+ type-fields
+ make-field-iterator
+ type-field
+ type-has-field?
+ field?
+ field-name
+ field-type
+ field-enumval
+ field-bitpos
+ field-bitsize
+ field-artificial?
+ field-baseclass?
+
+ ;; scm-value.c
+
+ value?
+ make-value
+ value-optimized-out?
+ value-address
+ value-type
+ value-dynamic-type
+ value-cast
+ value-dynamic-cast
+ value-reinterpret-cast
+ value-dereference
+ value-referenced-value
+ value-field
+ value-subscript
+ value-call
+ value->bool
+ value->integer
+ value->real
+ value->bytevector
+ value->string
+ value->lazy-string
+ value-lazy?
+ make-lazy-value
+ value-fetch-lazy!
+ value-print
+ parse-and-eval
+ history-ref
+)
+
+;; Load the rest of the Scheme side.
+;; data-directory is provided by the C code.
+
+(add-to-load-path
+ (string-append (data-directory) file-name-separator-string "guile"))
+
+(use-modules ((gdb init)))
+
+;; These come from other files, but they're really part of this module.
+
+(re-export
+
+ ;; init.scm
+ orig-input-port
+ orig-output-port
+ orig-error-port
+)
--- /dev/null
+;; Bootstrap the Scheme side of the gdb module.
+;;
+;; Copyright (C) 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/>.
+
+;; This file is loaded with scm_c_primitive_load, which is ok, but files
+;; loaded with it are not compiled. So we do very little here, and do
+;; most of the initialization elsewhere.
+
+;; data-directory is provided by the C code.
+(load (string-append
+ (data-directory) file-name-separator-string "guile"
+ file-name-separator-string "gdb.scm"))
+
+;; Now that the Scheme side support is loaded, initialize it.
+(let ((init-proc (@@ (gdb init) %initialize!)))
+ (init-proc))
--- /dev/null
+;; Various experimental utilities.
+;; Anything in this file can change or disappear.
+;;
+;; Copyright (C) 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/>.
+
+;; TODO: Split this file up by function?
+;; E.g., (gdb experimental ports), etc.
+
+(define-module (gdb experimental)
+ #:use-module (gdb)
+ #:use-module (gdb init))
+
+;; These are defined in C.
+(define-public with-gdb-output-to-port (@@ (gdb) %with-gdb-output-to-port))
+(define-public with-gdb-error-to-port (@@ (gdb) %with-gdb-error-to-port))
+
+(define-public (with-gdb-output-to-string thunk)
+ "Calls THUNK and returns all GDB output as a string."
+ (call-with-output-string
+ (lambda (p) (with-gdb-output-to-port p thunk))))
--- /dev/null
+;; Scheme side of the gdb module.
+;;
+;; Copyright (C) 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/>.
+
+(define-module (gdb init)
+ #:use-module (gdb))
+
+(define-public SCM_ARG1 1)
+(define-public SCM_ARG2 2)
+
+;; The original i/o ports. In case the user wants them back.
+(define %orig-input-port #f)
+(define %orig-output-port #f)
+(define %orig-error-port #f)
+
+;; %exception-print-style is exported as "private" by gdb.
+(define %exception-print-style (@@ (gdb) %exception-print-style))
+
+;; Keys for GDB-generated exceptions.
+;; gdb:with-stack is handled separately.
+
+(define %exception-keys '(gdb:error
+ gdb:invalid-object-error
+ gdb:memory-error
+ gdb:pp-type-error))
+
+;; Printer for gdb exceptions, used when Scheme tries to print them directly.
+
+(define (%exception-printer port key args default-printer)
+ (apply (case-lambda
+ ((subr msg args . rest)
+ (if subr
+ (format port "In procedure ~a: " subr))
+ (apply format port msg (or args '())))
+ (_ (default-printer)))
+ args))
+
+;; Print the message part of a gdb:with-stack exception.
+;; The arg list is the way it is because it's passed to set-exception-printer!.
+;; We don't print a backtrace here because Guile will have already printed a
+;; backtrace.
+
+(define (%with-stack-exception-printer port key args default-printer)
+ (let ((real-key (car args))
+ (real-args (cddr args)))
+ (%exception-printer port real-key real-args default-printer)))
+
+;; Copy of Guile's print-exception that tweaks the output for our purposes.
+;; TODO: It's not clear the tweaking is still necessary.
+
+(define (%print-exception-message-worker port key args)
+ (define (default-printer)
+ (format port "Throw to key `~a' with args `~s'." key args))
+ (format port "ERROR: ")
+ ;; Pass #t for tag to catch all errors.
+ (catch #t
+ (lambda ()
+ (%exception-printer port key args default-printer))
+ (lambda (k . args)
+ (format port "Error while printing gdb exception: ~a ~s."
+ k args)))
+ (newline port)
+ (force-output port))
+
+;; Called from the C code to print an exception.
+;; Guile prints them a little differently than we want.
+;; See boot-9.scm:print-exception.
+
+(define (%print-exception-message port frame key args)
+ (cond ((memq key %exception-keys)
+ (%print-exception-message-worker port key args))
+ (else
+ (print-exception port frame key args)))
+ *unspecified*)
+
+;; Called from the C code to print an exception according to the setting
+;; of "guile print-stack".
+;;
+;; If PORT is #f, use the standard error port.
+;; If STACK is #f, never print the stack, regardless of whether printing it
+;; is enabled. If STACK is #t, then print it if it is contained in ARGS
+;; (i.e., KEY is gdb:with-stack). Otherwise STACK is the result of calling
+;; scm_make_stack (which will be ignored in favor of the stack in ARGS if
+;; KEY is gdb:with-stack).
+;; KEY, ARGS are the standard arguments to scm_throw, et.al.
+
+(define (%print-exception-with-stack port stack key args)
+ (let ((style (%exception-print-style)))
+ (if (not (eq? style 'none))
+ (let ((error-port (current-error-port))
+ (frame #f))
+ (if (not port)
+ (set! port error-port))
+ (if (eq? port error-port)
+ (begin
+ (force-output (current-output-port))
+ ;; In case the current output port is not gdb's output port.
+ (force-output (output-port))))
+
+ ;; If the exception is gdb:with-stack, unwrap it to get the stack and
+ ;; underlying exception. If the caller happens to pass in a stack,
+ ;; we ignore it and use the one in ARGS instead.
+ (if (eq? key 'gdb:with-stack)
+ (begin
+ (set! key (car args))
+ (if stack
+ (set! stack (cadr args)))
+ (set! args (cddr args))))
+
+ ;; If caller wanted a stack and there isn't one, disable backtracing.
+ (if (eq? stack #t)
+ (set! stack #f))
+ ;; At this point if stack is true, then it is assumed to be a stack.
+ (if stack
+ (set! frame (stack-ref stack 0)))
+
+ (if (and (eq? style 'full) stack)
+ (begin
+ ;; This is derived from libguile/throw.c:handler_message.
+ ;; We include "Guile" in "Guile Backtrace" whereas the Guile
+ ;; version does not so that tests can know it's us printing
+ ;; the backtrace. Plus it could help beginners.
+ (display "Guile Backtrace:\n" port)
+ (display-backtrace stack port #f #f '())
+ (newline port)))
+
+ (%print-exception-message port frame key args)))))
+
+;; Internal utility to check the type of an argument, akin to SCM_ASSERT_TYPE.
+;; It's public so other gdb modules can use it.
+
+(define-public (%assert-type test-result arg pos func-name)
+ (if (not test-result)
+ (scm-error 'wrong-type-arg func-name
+ "Wrong type argument in position ~a: ~s"
+ (list pos arg) (list arg))))
+
+;; Internal utility called during startup to initialize the Scheme side of
+;; GDB+Guile.
+
+(define (%initialize!)
+ (add-to-load-path (string-append (data-directory)
+ file-name-separator-string "guile"))
+
+ (for-each (lambda (key)
+ (set-exception-printer! key %exception-printer))
+ %exception-keys)
+ (set-exception-printer! 'gdb:with-stack %with-stack-exception-printer)
+
+ (set! %orig-input-port (set-current-input-port (input-port)))
+ (set! %orig-output-port (set-current-output-port (output-port)))
+ (set! %orig-error-port (set-current-error-port (error-port))))
+\f
+;; Public routines.
+
+(define-public (orig-input-port) %orig-input-port)
+(define-public (orig-output-port) %orig-output-port)
+(define-public (orig-error-port) %orig-error-port)
--- /dev/null
+;; Iteration utilities.
+;; Anything in this file can change or disappear.
+;;
+;; Copyright (C) 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/>.
+
+(define-module (gdb iterator)
+ #:use-module (gdb))
+
+(define-public (make-list-iterator l)
+ "Return a <gdb:iterator> object for a list."
+ (%assert-type (list? l) l SCM_ARG1 'make-list-iterator)
+ (let ((next! (lambda (iter)
+ (let ((l (iterator-progress iter)))
+ (if (eq? l '())
+ (end-of-iteration)
+ (begin
+ (set-iterator-progress! iter (cdr l))
+ (car l)))))))
+ (make-iterator l l next!)))
+
+(define-public (iterator->list iter)
+ "Return the elements of ITER as a list."
+ (let loop ((iter iter)
+ (result '()))
+ (let ((next (iterator-next! iter)))
+ (if (end-of-iteration? next)
+ (reverse! result)
+ (loop iter (cons next result))))))
+
+(define-public (iterator-map proc iter)
+ "Return a list of PROC applied to each element."
+ (let loop ((proc proc)
+ (iter iter)
+ (result '()))
+ (let ((next (iterator-next! iter)))
+ (if (end-of-iteration? next)
+ (reverse! result)
+ (loop proc iter (cons (proc next) result))))))
+
+(define-public (iterator-for-each proc iter)
+ "Apply PROC to each element. The result is unspecified."
+ (let ((next (iterator-next! iter)))
+ (if (not (end-of-iteration? next))
+ (begin
+ (proc next)
+ (iterator-for-each proc iter)))))
+
+(define-public (iterator-filter pred iter)
+ "Return the elements that satify predicate PRED."
+ (let loop ((result '()))
+ (let ((next (iterator-next! iter)))
+ (cond ((end-of-iteration? next) (reverse! result))
+ ((pred next) (loop (cons next result)))
+ (else (loop result))))))
+
+(define-public (iterator-until pred iter)
+ "Run the iterator until the result of (pred element) is true.
+
+ Returns:
+ The result of the first (pred element) call that returns true,
+ or #f if no element matches."
+ (let loop ((next (iterator-next! iter)))
+ (cond ((end-of-iteration? next) #f)
+ ((pred next) => identity)
+ (else (loop (iterator-next! iter))))))
--- /dev/null
+;; Additional pretty-printer support.
+;;
+;; Copyright (C) 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/>.
+
+(define-module (gdb printing)
+ #:use-module ((gdb) #:select
+ (*pretty-printers* pretty-printer? objfile?
+ objfile-pretty-printers set-objfile-pretty-printers!))
+ #:use-module (gdb init))
+
+(define-public (prepend-pretty-printer! obj matcher)
+ "Add MATCHER to the beginning of the pretty-printer list for OBJ.
+If OBJ is #f, add MATCHER to the global list."
+ (%assert-type (pretty-printer? matcher) matcher SCM_ARG1
+ 'prepend-pretty-printer!)
+ (cond ((eq? obj #f)
+ (set! *pretty-printers* (cons matcher *pretty-printers*)))
+ ((objfile? obj)
+ (set-objfile-pretty-printers! obj
+ (cons matcher
+ (objfile-pretty-printers obj))))
+ (else
+ (%assert-type #f obj SCM_ARG1 'prepend-pretty-printer!))))
+
+(define-public (append-pretty-printer! obj matcher)
+ "Add MATCHER to the end of the pretty-printer list for OBJ.
+If OBJ is #f, add MATCHER to the global list."
+ (%assert-type (pretty-printer? matcher) matcher SCM_ARG1
+ 'append-pretty-printer!)
+ (cond ((eq? obj #f)
+ (set! *pretty-printers* (append! *pretty-printers* (list matcher))))
+ ((objfile? obj)
+ (set-objfile-pretty-printers! obj
+ (append! (objfile-pretty-printers obj)
+ matcher)))
+ (else
+ (%assert-type #f obj SCM_ARG1 'append-pretty-printer!))))
--- /dev/null
+;; Type utilities.
+;; Copyright (C) 2010-2014 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/>.
+
+(define-module (gdb types)
+ #:use-module (gdb)
+ #:use-module (gdb init)
+ #:use-module (gdb iterator))
+
+(define-public (type-has-field-deep? type field-name)
+ "Return #t if the type, including baseclasses, has the specified field.
+
+ Arguments:
+ type: The type to examine. It must be a struct or union.
+ field-name: The name of the field to look up.
+
+ Returns:
+ True if the field is present either in type_ or any baseclass.
+
+ Raises:
+ wrong-type-arg: The type is not a struct or union."
+
+ (define (search-class type)
+ (let ((find-in-baseclass (lambda (field)
+ (if (field-baseclass? field)
+ (search-class (field-type field))
+ ;; Not a baseclass, search ends now.
+ ;; Return #:end to end search.
+ #:end))))
+ (let ((search-baseclasses
+ (lambda (type)
+ (iterator-until find-in-baseclass
+ (make-field-iterator type)))))
+ (or (type-has-field? type field-name)
+ (not (eq? (search-baseclasses type) #:end))))))
+
+ (if (= (type-code type) TYPE_CODE_REF)
+ (set! type (type-target type)))
+ (set! type (type-strip-typedefs type))
+
+ (%assert-type (memq (type-code type) (list TYPE_CODE_STRUCT TYPE_CODE_UNION))
+ type SCM_ARG1 'type-has-field-deep?)
+
+ (search-class type))
+
+(define-public (make-enum-hashtable enum-type)
+ "Return a hash table from a program's enum type.
+
+ Elements in the hash table are fetched with hashq-ref.
+
+ Arguments:
+ enum-type: The enum to compute the hash table for.
+
+ Returns:
+ The hash table of the enum.
+
+ Raises:
+ wrong-type-arg: The type is not an enum."
+
+ (%assert-type (= (type-code enum-type) TYPE_CODE_ENUM)
+ enum-type SCM_ARG1 'make-enum-hashtable)
+ (let ((htab (make-hash-table)))
+ (for-each (lambda (enum)
+ (hash-set! htab (field-name enum) (field-enumval enum)))
+ (type-fields enum-type))
+ htab))
--- /dev/null
+/* Scheme interface to architecture.
+
+ Copyright (C) 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 "charset.h"
+#include "gdbarch.h"
+#include "arch-utils.h"
+#include "guile-internal.h"
+
+/* The <gdb:arch> smob.
+ The typedef for this struct is in guile-internal.h. */
+
+struct _arch_smob
+{
+ /* This always appears first. */
+ gdb_smob base;
+
+ struct gdbarch *gdbarch;
+};
+
+static const char arch_smob_name[] = "gdb:arch";
+
+/* The tag Guile knows the arch smob by. */
+static scm_t_bits arch_smob_tag;
+
+static struct gdbarch_data *arch_object_data = NULL;
+
+static int arscm_is_arch (SCM);
+\f
+/* Administrivia for arch smobs. */
+
+/* The smob "mark" function for <gdb:arch>. */
+
+static SCM
+arscm_mark_arch_smob (SCM self)
+{
+ arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (self);
+
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&a_smob->base);
+}
+
+/* The smob "print" function for <gdb:arch>. */
+
+static int
+arscm_print_arch_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (self);
+ struct gdbarch *gdbarch = a_smob->gdbarch;
+
+ gdbscm_printf (port, "#<%s", arch_smob_name);
+ gdbscm_printf (port, " %s", gdbarch_bfd_arch_info (gdbarch)->printable_name);
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to create a <gdb:arch> object for GDBARCH. */
+
+static SCM
+arscm_make_arch_smob (struct gdbarch *gdbarch)
+{
+ arch_smob *a_smob = (arch_smob *)
+ scm_gc_malloc (sizeof (arch_smob), arch_smob_name);
+ SCM a_scm;
+
+ a_smob->gdbarch = gdbarch;
+ a_scm = scm_new_smob (arch_smob_tag, (scm_t_bits) a_smob);
+ gdbscm_init_gsmob (&a_smob->base);
+
+ return a_scm;
+}
+
+/* Return the gdbarch field of A_SMOB. */
+
+struct gdbarch *
+arscm_get_gdbarch (arch_smob *a_smob)
+{
+ return a_smob->gdbarch;
+}
+
+/* Return non-zero if SCM is an architecture smob. */
+
+static int
+arscm_is_arch (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (arch_smob_tag, scm);
+}
+
+/* (arch? object) -> boolean */
+
+static SCM
+gdbscm_arch_p (SCM scm)
+{
+ return scm_from_bool (arscm_is_arch (scm));
+}
+
+/* Associates an arch_object with GDBARCH as gdbarch_data via the gdbarch
+ post init registration mechanism (gdbarch_data_register_post_init). */
+
+static void *
+arscm_object_data_init (struct gdbarch *gdbarch)
+{
+ SCM arch_scm = arscm_make_arch_smob (gdbarch);
+
+ /* This object lasts the duration of the GDB session, so there is no
+ call to scm_gc_unprotect_object for it. */
+ scm_gc_protect_object (arch_scm);
+
+ return (void *) arch_scm;
+}
+
+/* Return the <gdb:arch> object corresponding to GDBARCH.
+ The object is cached in GDBARCH so this is simple. */
+
+SCM
+arscm_scm_from_arch (struct gdbarch *gdbarch)
+{
+ SCM a_scm = (SCM) gdbarch_data (gdbarch, arch_object_data);
+
+ return a_scm;
+}
+
+/* Return the <gdb:arch> smob in SELF.
+ Throws an exception if SELF is not a <gdb:arch> object. */
+
+static SCM
+arscm_get_arch_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (arscm_is_arch (self), self, arg_pos, func_name,
+ arch_smob_name);
+
+ return self;
+}
+
+/* Return a pointer to the arch smob of SELF.
+ Throws an exception if SELF is not a <gdb:arch> object. */
+
+arch_smob *
+arscm_get_arch_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM a_scm = arscm_get_arch_arg_unsafe (self, arg_pos, func_name);
+ arch_smob *a_smob = (arch_smob *) SCM_SMOB_DATA (a_scm);
+
+ return a_smob;
+}
+\f
+/* Arch methods. */
+
+/* (current-arch) -> <gdb:arch>
+ Return the architecture of the currently selected stack frame,
+ if there is one, or the current target if there isn't. */
+
+static SCM
+gdbscm_current_arch (void)
+{
+ return arscm_scm_from_arch (get_current_arch ());
+}
+
+/* (arch-name <gdb:arch>) -> string
+ Return the name of the architecture as a string value. */
+
+static SCM
+gdbscm_arch_name (SCM self)
+{
+ arch_smob *a_smob
+ = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct gdbarch *gdbarch = a_smob->gdbarch;
+ const char *name;
+
+ name = (gdbarch_bfd_arch_info (gdbarch))->printable_name;
+
+ return gdbscm_scm_from_c_string (name);
+}
+
+/* (arch-charset <gdb:arch>) -> string */
+
+static SCM
+gdbscm_arch_charset (SCM self)
+{
+ arch_smob *a_smob
+ =arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct gdbarch *gdbarch = a_smob->gdbarch;
+
+ return gdbscm_scm_from_c_string (target_charset (gdbarch));
+}
+
+/* (arch-wide-charset <gdb:arch>) -> string */
+
+static SCM
+gdbscm_arch_wide_charset (SCM self)
+{
+ arch_smob *a_smob
+ = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct gdbarch *gdbarch = a_smob->gdbarch;
+
+ return gdbscm_scm_from_c_string (target_wide_charset (gdbarch));
+}
+\f
+/* Builtin types.
+
+ The order the types are defined here follows the order in
+ struct builtin_type. */
+
+/* Helper routine to return a builtin type for <gdb:arch> object SELF.
+ OFFSET is offsetof (builtin_type, the_type).
+ Throws an exception if SELF is not a <gdb:arch> object. */
+
+static const struct builtin_type *
+gdbscm_arch_builtin_type (SCM self, const char *func_name)
+{
+ arch_smob *a_smob
+ = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, func_name);
+ struct gdbarch *gdbarch = a_smob->gdbarch;
+
+ return builtin_type (gdbarch);
+}
+
+/* (arch-void-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_void_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_void;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-char-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_char_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_char;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-short-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_short_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_short;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-int-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_int_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-long-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_long_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-schar-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_schar_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_signed_char;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-uchar-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_uchar_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_char;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-ushort-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_ushort_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_short;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-uint-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_uint_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_int;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-ulong-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_ulong_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_long;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-float-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_float_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_float;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-double-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_double_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_double;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-longdouble-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_longdouble_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long_double;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-bool-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_bool_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_bool;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-longlong-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_longlong_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_long_long;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-ulonglong-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_ulonglong_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_unsigned_long_long;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-int8-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_int8_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int8;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-uint8-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_uint8_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint8;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-int16-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_int16_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int16;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-uint16-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_uint16_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint16;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-int32-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_int32_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int32;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-uint32-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_uint32_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint32;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-int64-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_int64_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_int64;
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (arch-uint64-type <gdb:arch>) -> <gdb:type> */
+
+static SCM
+gdbscm_arch_uint64_type (SCM self)
+{
+ struct type *type
+ = gdbscm_arch_builtin_type (self, FUNC_NAME)->builtin_uint64;
+
+ return tyscm_scm_from_type (type);
+}
+\f
+/* Initialize the Scheme architecture support. */
+
+static const scheme_function arch_functions[] =
+{
+ { "arch?", 1, 0, 0, gdbscm_arch_p,
+ "\
+Return #t if the object is a <gdb:arch> object." },
+
+ { "current-arch", 0, 0, 0, gdbscm_current_arch,
+ "\
+Return the <gdb:arch> object representing the architecture of the\n\
+currently selected stack frame, if there is one, or the architecture of the\n\
+current target if there isn't.\n\
+\n\
+ Arguments: none" },
+
+ { "arch-name", 1, 0, 0, gdbscm_arch_name,
+ "\
+Return the name of the architecture." },
+
+ { "arch-charset", 1, 0, 0, gdbscm_arch_charset,
+ "\
+Return name of target character set as a string." },
+
+ { "arch-wide-charset", 1, 0, 0, gdbscm_arch_wide_charset,
+ "\
+Return name of target wide character set as a string." },
+
+ { "arch-void-type", 1, 0, 0, gdbscm_arch_void_type,
+ "\
+Return the <gdb:type> object for the \"void\" type\n\
+of the architecture." },
+
+ { "arch-char-type", 1, 0, 0, gdbscm_arch_char_type,
+ "\
+Return the <gdb:type> object for the \"char\" type\n\
+of the architecture." },
+
+ { "arch-short-type", 1, 0, 0, gdbscm_arch_short_type,
+ "\
+Return the <gdb:type> object for the \"short\" type\n\
+of the architecture." },
+
+ { "arch-int-type", 1, 0, 0, gdbscm_arch_int_type,
+ "\
+Return the <gdb:type> object for the \"int\" type\n\
+of the architecture." },
+
+ { "arch-long-type", 1, 0, 0, gdbscm_arch_long_type,
+ "\
+Return the <gdb:type> object for the \"long\" type\n\
+of the architecture." },
+
+ { "arch-schar-type", 1, 0, 0, gdbscm_arch_schar_type,
+ "\
+Return the <gdb:type> object for the \"signed char\" type\n\
+of the architecture." },
+
+ { "arch-uchar-type", 1, 0, 0, gdbscm_arch_uchar_type,
+ "\
+Return the <gdb:type> object for the \"unsigned char\" type\n\
+of the architecture." },
+
+ { "arch-ushort-type", 1, 0, 0, gdbscm_arch_ushort_type,
+ "\
+Return the <gdb:type> object for the \"unsigned short\" type\n\
+of the architecture." },
+
+ { "arch-uint-type", 1, 0, 0, gdbscm_arch_uint_type,
+ "\
+Return the <gdb:type> object for the \"unsigned int\" type\n\
+of the architecture." },
+
+ { "arch-ulong-type", 1, 0, 0, gdbscm_arch_ulong_type,
+ "\
+Return the <gdb:type> object for the \"unsigned long\" type\n\
+of the architecture." },
+
+ { "arch-float-type", 1, 0, 0, gdbscm_arch_float_type,
+ "\
+Return the <gdb:type> object for the \"float\" type\n\
+of the architecture." },
+
+ { "arch-double-type", 1, 0, 0, gdbscm_arch_double_type,
+ "\
+Return the <gdb:type> object for the \"double\" type\n\
+of the architecture." },
+
+ { "arch-longdouble-type", 1, 0, 0, gdbscm_arch_longdouble_type,
+ "\
+Return the <gdb:type> object for the \"long double\" type\n\
+of the architecture." },
+
+ { "arch-bool-type", 1, 0, 0, gdbscm_arch_bool_type,
+ "\
+Return the <gdb:type> object for the \"bool\" type\n\
+of the architecture." },
+
+ { "arch-longlong-type", 1, 0, 0, gdbscm_arch_longlong_type,
+ "\
+Return the <gdb:type> object for the \"long long\" type\n\
+of the architecture." },
+
+ { "arch-ulonglong-type", 1, 0, 0,
+ gdbscm_arch_ulonglong_type,
+ "\
+Return the <gdb:type> object for the \"unsigned long long\" type\n\
+of the architecture." },
+
+ { "arch-int8-type", 1, 0, 0, gdbscm_arch_int8_type,
+ "\
+Return the <gdb:type> object for the \"int8\" type\n\
+of the architecture." },
+
+ { "arch-uint8-type", 1, 0, 0, gdbscm_arch_uint8_type,
+ "\
+Return the <gdb:type> object for the \"uint8\" type\n\
+of the architecture." },
+
+ { "arch-int16-type", 1, 0, 0, gdbscm_arch_int16_type,
+ "\
+Return the <gdb:type> object for the \"int16\" type\n\
+of the architecture." },
+
+ { "arch-uint16-type", 1, 0, 0, gdbscm_arch_uint16_type,
+ "\
+Return the <gdb:type> object for the \"uint16\" type\n\
+of the architecture." },
+
+ { "arch-int32-type", 1, 0, 0, gdbscm_arch_int32_type,
+ "\
+Return the <gdb:type> object for the \"int32\" type\n\
+of the architecture." },
+
+ { "arch-uint32-type", 1, 0, 0, gdbscm_arch_uint32_type,
+ "\
+Return the <gdb:type> object for the \"uint32\" type\n\
+of the architecture." },
+
+ { "arch-int64-type", 1, 0, 0, gdbscm_arch_int64_type,
+ "\
+Return the <gdb:type> object for the \"int64\" type\n\
+of the architecture." },
+
+ { "arch-uint64-type", 1, 0, 0, gdbscm_arch_uint64_type,
+ "\
+Return the <gdb:type> object for the \"uint64\" type\n\
+of the architecture." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_arches (void)
+{
+ arch_smob_tag = gdbscm_make_smob_type (arch_smob_name, sizeof (arch_smob));
+ scm_set_smob_mark (arch_smob_tag, arscm_mark_arch_smob);
+ scm_set_smob_print (arch_smob_tag, arscm_print_arch_smob);
+
+ gdbscm_define_functions (arch_functions, 1);
+
+ arch_object_data
+ = gdbarch_data_register_post_init (arscm_object_data_init);
+}
--- /dev/null
+/* GDB routines for supporting auto-loaded Guile scripts.
+
+ Copyright (C) 2010-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/>. */
+
+#include "defs.h"
+#include <string.h>
+#include "top.h"
+#include "exceptions.h"
+#include "gdbcmd.h"
+#include "objfiles.h"
+#include "cli/cli-cmds.h"
+#include "auto-load.h"
+#include "guile.h"
+#include "guile-internal.h"
+
+/* User-settable option to enable/disable auto-loading of Guile scripts:
+ set auto-load guile-scripts on|off
+ This is true if we should auto-load associated Guile scripts when an
+ objfile is opened, false otherwise. */
+static int auto_load_guile_scripts = 1;
+
+/* "show" command for the auto_load_guile_scripts configuration variable. */
+
+static void
+show_auto_load_guile_scripts (struct ui_file *file, int from_tty,
+ struct cmd_list_element *c, const char *value)
+{
+ fprintf_filtered (file, _("Auto-loading of Guile scripts is %s.\n"), value);
+}
+
+/* Return non-zero if auto-loading Guile scripts is enabled.
+ This is the extension_language_script_ops.auto_load_enabled "method". */
+
+int
+gdbscm_auto_load_enabled (const struct extension_language_defn *extlang)
+{
+ return auto_load_guile_scripts;
+}
+
+/* Wrapper for "info auto-load guile-scripts". */
+
+static void
+info_auto_load_guile_scripts (char *pattern, int from_tty)
+{
+ auto_load_info_scripts (pattern, from_tty, &extension_language_guile);
+}
+\f
+void
+gdbscm_initialize_auto_load (void)
+{
+ add_setshow_boolean_cmd ("guile-scripts", class_support,
+ &auto_load_guile_scripts, _("\
+Set the debugger's behaviour regarding auto-loaded Guile scripts."), _("\
+Show the debugger's behaviour regarding auto-loaded Guile scripts."), _("\
+If enabled, auto-loaded Guile scripts are loaded when the debugger reads\n\
+an executable or shared library.\n\
+This options has security implications for untrusted inferiors."),
+ NULL, show_auto_load_guile_scripts,
+ auto_load_set_cmdlist_get (),
+ auto_load_show_cmdlist_get ());
+
+ add_cmd ("guile-scripts", class_info, info_auto_load_guile_scripts,
+ _("Print the list of automatically loaded Guile scripts.\n\
+Usage: info auto-load guile-scripts [REGEXP]"),
+ auto_load_info_cmdlist_get ());
+}
--- /dev/null
+/* Scheme interface to blocks.
+
+ 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 "block.h"
+#include "dictionary.h"
+#include "objfiles.h"
+#include "source.h"
+#include "symtab.h"
+#include "guile-internal.h"
+
+/* A smob describing a gdb block. */
+
+typedef struct _block_smob
+{
+ /* This always appears first.
+ We want blocks to be eq?-able. And we need to be able to invalidate
+ blocks when the associated objfile is deleted. */
+ eqable_gdb_smob base;
+
+ /* The GDB block structure that represents a frame's code block. */
+ const struct block *block;
+
+ /* The backing object file. There is no direct relationship in GDB
+ between a block and an object file. When a block is created also
+ store a pointer to the object file for later use. */
+ struct objfile *objfile;
+} block_smob;
+
+/* To iterate over block symbols from Scheme we need to store
+ struct block_iterator somewhere. This is stored in the "progress" field
+ of <gdb:iterator>. We store the block object in iterator_smob.object,
+ so we don't store it here.
+
+ Remember: While iterating over block symbols, you must continually check
+ whether the block is still valid. */
+
+typedef struct
+{
+ /* This always appears first. */
+ gdb_smob base;
+
+ /* The iterator for that block. */
+ struct block_iterator iter;
+
+ /* Has the iterator been initialized flag. */
+ int initialized_p;
+} block_syms_progress_smob;
+
+static const char block_smob_name[] = "gdb:block";
+static const char block_syms_progress_smob_name[] = "gdb:block-symbols-iterator";
+
+/* The tag Guile knows the block smobs by. */
+static scm_t_bits block_smob_tag;
+static scm_t_bits block_syms_progress_smob_tag;
+
+/* The "next!" block syms iterator method. */
+static SCM bkscm_next_symbol_x_proc;
+
+static const struct objfile_data *bkscm_objfile_data_key;
+\f
+/* Administrivia for block smobs. */
+
+/* Helper function to hash a block_smob. */
+
+static hashval_t
+bkscm_hash_block_smob (const void *p)
+{
+ const block_smob *b_smob = p;
+
+ return htab_hash_pointer (b_smob->block);
+}
+
+/* Helper function to compute equality of block_smobs. */
+
+static int
+bkscm_eq_block_smob (const void *ap, const void *bp)
+{
+ const block_smob *a = ap;
+ const block_smob *b = bp;
+
+ return (a->block == b->block
+ && a->block != NULL);
+}
+
+/* Return the struct block pointer -> SCM mapping table.
+ It is created if necessary. */
+
+static htab_t
+bkscm_objfile_block_map (struct objfile *objfile)
+{
+ htab_t htab = objfile_data (objfile, bkscm_objfile_data_key);
+
+ if (htab == NULL)
+ {
+ htab = gdbscm_create_eqable_gsmob_ptr_map (bkscm_hash_block_smob,
+ bkscm_eq_block_smob);
+ set_objfile_data (objfile, bkscm_objfile_data_key, htab);
+ }
+
+ return htab;
+}
+
+/* The smob "mark" function for <gdb:block>. */
+
+static SCM
+bkscm_mark_block_smob (SCM self)
+{
+ block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self);
+
+ /* Do this last. */
+ return gdbscm_mark_eqable_gsmob (&b_smob->base);
+}
+
+/* The smob "free" function for <gdb:block>. */
+
+static size_t
+bkscm_free_block_smob (SCM self)
+{
+ block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self);
+
+ if (b_smob->block != NULL)
+ {
+ htab_t htab = bkscm_objfile_block_map (b_smob->objfile);
+
+ gdbscm_clear_eqable_gsmob_ptr_slot (htab, &b_smob->base);
+ }
+
+ /* Not necessary, done to catch bugs. */
+ b_smob->block = NULL;
+ b_smob->objfile = NULL;
+
+ return 0;
+}
+
+/* The smob "print" function for <gdb:block>. */
+
+static int
+bkscm_print_block_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (self);
+ const struct block *b = b_smob->block;
+
+ gdbscm_printf (port, "#<%s", block_smob_name);
+
+ if (BLOCK_SUPERBLOCK (b) == NULL)
+ gdbscm_printf (port, " global");
+ else if (BLOCK_SUPERBLOCK (BLOCK_SUPERBLOCK (b)) == NULL)
+ gdbscm_printf (port, " static");
+
+ if (BLOCK_FUNCTION (b) != NULL)
+ gdbscm_printf (port, " %s", SYMBOL_PRINT_NAME (BLOCK_FUNCTION (b)));
+
+ gdbscm_printf (port, " %s-%s",
+ hex_string (BLOCK_START (b)), hex_string (BLOCK_END (b)));
+
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to create a <gdb:block> object. */
+
+static SCM
+bkscm_make_block_smob (void)
+{
+ block_smob *b_smob = (block_smob *)
+ scm_gc_malloc (sizeof (block_smob), block_smob_name);
+ SCM b_scm;
+
+ b_smob->block = NULL;
+ b_smob->objfile = NULL;
+ b_scm = scm_new_smob (block_smob_tag, (scm_t_bits) b_smob);
+ gdbscm_init_eqable_gsmob (&b_smob->base);
+
+ return b_scm;
+}
+
+/* Returns non-zero if SCM is a <gdb:block> object. */
+
+static int
+bkscm_is_block (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (block_smob_tag, scm);
+}
+
+/* (block? scm) -> boolean */
+
+static SCM
+gdbscm_block_p (SCM scm)
+{
+ return scm_from_bool (bkscm_is_block (scm));
+}
+
+/* Return the existing object that encapsulates BLOCK, or create a new
+ <gdb:block> object. */
+
+SCM
+bkscm_scm_from_block (const struct block *block, struct objfile *objfile)
+{
+ htab_t htab;
+ eqable_gdb_smob **slot;
+ block_smob *b_smob, b_smob_for_lookup;
+ SCM b_scm;
+
+ /* If we've already created a gsmob for this block, return it.
+ This makes blocks eq?-able. */
+ htab = bkscm_objfile_block_map (objfile);
+ b_smob_for_lookup.block = block;
+ slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &b_smob_for_lookup.base);
+ if (*slot != NULL)
+ return (*slot)->containing_scm;
+
+ b_scm = bkscm_make_block_smob ();
+ b_smob = (block_smob *) SCM_SMOB_DATA (b_scm);
+ b_smob->block = block;
+ b_smob->objfile = objfile;
+ gdbscm_fill_eqable_gsmob_ptr_slot (slot, &b_smob->base, b_scm);
+
+ return b_scm;
+}
+
+/* Returns the <gdb:block> object in SELF.
+ Throws an exception if SELF is not a <gdb:block> object. */
+
+static SCM
+bkscm_get_block_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (bkscm_is_block (self), self, arg_pos, func_name,
+ block_smob_name);
+
+ return self;
+}
+
+/* Returns a pointer to the block smob of SELF.
+ Throws an exception if SELF is not a <gdb:block> object. */
+
+static block_smob *
+bkscm_get_block_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM b_scm = bkscm_get_block_arg_unsafe (self, arg_pos, func_name);
+ block_smob *b_smob = (block_smob *) SCM_SMOB_DATA (b_scm);
+
+ return b_smob;
+}
+
+/* Returns non-zero if block B_SMOB is valid. */
+
+static int
+bkscm_is_valid (block_smob *b_smob)
+{
+ return b_smob->block != NULL;
+}
+
+/* Returns the block smob in SELF, verifying it's valid.
+ Throws an exception if SELF is not a <gdb:block> object or is invalid. */
+
+static block_smob *
+bkscm_get_valid_block_smob_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ block_smob *b_smob
+ = bkscm_get_block_smob_arg_unsafe (self, arg_pos, func_name);
+
+ if (!bkscm_is_valid (b_smob))
+ {
+ gdbscm_invalid_object_error (func_name, arg_pos, self,
+ _("<gdb:block>"));
+ }
+
+ return b_smob;
+}
+
+/* Returns the block smob contained in SCM or NULL if SCM is not a
+ <gdb:block> object.
+ If there is an error a <gdb:exception> object is stored in *EXCP. */
+
+static block_smob *
+bkscm_get_valid_block (SCM scm, int arg_pos, const char *func_name, SCM *excp)
+{
+ block_smob *b_smob;
+
+ if (!bkscm_is_block (scm))
+ {
+ *excp = gdbscm_make_type_error (func_name, arg_pos, scm,
+ block_smob_name);
+ return NULL;
+ }
+
+ b_smob = (block_smob *) SCM_SMOB_DATA (scm);
+ if (!bkscm_is_valid (b_smob))
+ {
+ *excp = gdbscm_make_invalid_object_error (func_name, arg_pos, scm,
+ _("<gdb:block>"));
+ return NULL;
+ }
+
+ return b_smob;
+}
+
+/* Returns the struct block that is wrapped by BLOCK_SCM.
+ If BLOCK_SCM is not a block, or is an invalid block, then NULL is returned
+ and a <gdb:exception> object is stored in *EXCP. */
+
+const struct block *
+bkscm_scm_to_block (SCM block_scm, int arg_pos, const char *func_name,
+ SCM *excp)
+{
+ block_smob *b_smob;
+
+ b_smob = bkscm_get_valid_block (block_scm, arg_pos, func_name, excp);
+
+ if (b_smob != NULL)
+ return b_smob->block;
+ return NULL;
+}
+
+/* Helper function for bkscm_del_objfile_blocks to mark the block
+ as invalid. */
+
+static int
+bkscm_mark_block_invalid (void **slot, void *info)
+{
+ block_smob *b_smob = (block_smob *) *slot;
+
+ b_smob->block = NULL;
+ b_smob->objfile = NULL;
+ return 1;
+}
+
+/* This function is called when an objfile is about to be freed.
+ Invalidate the block as further actions on the block would result
+ in bad data. All access to b_smob->block should be gated by
+ checks to ensure the block is (still) valid. */
+
+static void
+bkscm_del_objfile_blocks (struct objfile *objfile, void *datum)
+{
+ htab_t htab = datum;
+
+ if (htab != NULL)
+ {
+ htab_traverse_noresize (htab, bkscm_mark_block_invalid, NULL);
+ htab_delete (htab);
+ }
+}
+\f
+/* Block methods. */
+
+/* (block-valid? <gdb:block>) -> boolean
+ Returns #t if SELF still exists in GDB. */
+
+static SCM
+gdbscm_block_valid_p (SCM self)
+{
+ block_smob *b_smob
+ = bkscm_get_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_bool (bkscm_is_valid (b_smob));
+}
+
+/* (block-start <gdb:block>) -> address */
+
+static SCM
+gdbscm_block_start (SCM self)
+{
+ block_smob *b_smob
+ = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct block *block = b_smob->block;
+
+ return gdbscm_scm_from_ulongest (BLOCK_START (block));
+}
+
+/* (block-end <gdb:block>) -> address */
+
+static SCM
+gdbscm_block_end (SCM self)
+{
+ block_smob *b_smob
+ = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct block *block = b_smob->block;
+
+ return gdbscm_scm_from_ulongest (BLOCK_END (block));
+}
+
+/* (block-function <gdb:block>) -> <gdb:symbol> */
+
+static SCM
+gdbscm_block_function (SCM self)
+{
+ block_smob *b_smob
+ = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct block *block = b_smob->block;
+ struct symbol *sym;
+
+ sym = BLOCK_FUNCTION (block);
+
+ if (sym != NULL)
+ return syscm_scm_from_symbol (sym);
+ return SCM_BOOL_F;
+}
+
+/* (block-superblock <gdb:block>) -> <gdb:block> */
+
+static SCM
+gdbscm_block_superblock (SCM self)
+{
+ block_smob *b_smob
+ = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct block *block = b_smob->block;
+ const struct block *super_block;
+
+ super_block = BLOCK_SUPERBLOCK (block);
+
+ if (super_block)
+ return bkscm_scm_from_block (super_block, b_smob->objfile);
+ return SCM_BOOL_F;
+}
+
+/* (block-global-block <gdb:block>) -> <gdb:block>
+ Returns the global block associated to this block. */
+
+static SCM
+gdbscm_block_global_block (SCM self)
+{
+ block_smob *b_smob
+ = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct block *block = b_smob->block;
+ const struct block *global_block;
+
+ global_block = block_global_block (block);
+
+ return bkscm_scm_from_block (global_block, b_smob->objfile);
+}
+
+/* (block-static-block <gdb:block>) -> <gdb:block>
+ Returns the static block associated to this block.
+ Returns #f if we cannot get the static block (this is the global block). */
+
+static SCM
+gdbscm_block_static_block (SCM self)
+{
+ block_smob *b_smob
+ = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct block *block = b_smob->block;
+ const struct block *static_block;
+
+ if (BLOCK_SUPERBLOCK (block) == NULL)
+ return SCM_BOOL_F;
+
+ static_block = block_static_block (block);
+
+ return bkscm_scm_from_block (static_block, b_smob->objfile);
+}
+
+/* (block-global? <gdb:block>) -> boolean
+ Returns #t if this block object is a global block. */
+
+static SCM
+gdbscm_block_global_p (SCM self)
+{
+ block_smob *b_smob
+ = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct block *block = b_smob->block;
+
+ return scm_from_bool (BLOCK_SUPERBLOCK (block) == NULL);
+}
+
+/* (block-static? <gdb:block>) -> boolean
+ Returns #t if this block object is a static block. */
+
+static SCM
+gdbscm_block_static_p (SCM self)
+{
+ block_smob *b_smob
+ = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct block *block = b_smob->block;
+
+ if (BLOCK_SUPERBLOCK (block) != NULL
+ && BLOCK_SUPERBLOCK (BLOCK_SUPERBLOCK (block)) == NULL)
+ return SCM_BOOL_T;
+ return SCM_BOOL_F;
+}
+
+/* (block-symbols <gdb:block>) -> list of <gdb:symbol objects
+ Returns a list of symbols of the block. */
+
+static SCM
+gdbscm_block_symbols (SCM self)
+{
+ block_smob *b_smob
+ = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct block *block = b_smob->block;
+ struct block_iterator iter;
+ struct symbol *sym;
+ SCM result;
+
+ result = SCM_EOL;
+
+ sym = block_iterator_first (block, &iter);
+
+ while (sym != NULL)
+ {
+ SCM s_scm = syscm_scm_from_symbol (sym);
+
+ result = scm_cons (s_scm, result);
+ sym = block_iterator_next (&iter);
+ }
+
+ return scm_reverse_x (result, SCM_EOL);
+}
+\f
+/* The <gdb:block-symbols-iterator> object,
+ for iterating over all symbols in a block. */
+
+/* The smob "mark" function for <gdb:block-symbols-iterator>. */
+
+static SCM
+bkscm_mark_block_syms_progress_smob (SCM self)
+{
+ block_syms_progress_smob *i_smob
+ = (block_syms_progress_smob *) SCM_SMOB_DATA (self);
+
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&i_smob->base);
+}
+
+/* The smob "print" function for <gdb:block-symbols-iterator>. */
+
+static int
+bkscm_print_block_syms_progress_smob (SCM self, SCM port,
+ scm_print_state *pstate)
+{
+ block_syms_progress_smob *i_smob
+ = (block_syms_progress_smob *) SCM_SMOB_DATA (self);
+
+ gdbscm_printf (port, "#<%s", block_syms_progress_smob_name);
+
+ if (i_smob->initialized_p)
+ {
+ switch (i_smob->iter.which)
+ {
+ case GLOBAL_BLOCK:
+ case STATIC_BLOCK:
+ {
+ struct symtab *s;
+
+ gdbscm_printf (port, " %s",
+ i_smob->iter.which == GLOBAL_BLOCK
+ ? "global" : "static");
+ if (i_smob->iter.idx != -1)
+ gdbscm_printf (port, " @%d", i_smob->iter.idx);
+ s = (i_smob->iter.idx == -1
+ ? i_smob->iter.d.symtab
+ : i_smob->iter.d.symtab->includes[i_smob->iter.idx]);
+ gdbscm_printf (port, " %s", symtab_to_filename_for_display (s));
+ break;
+ }
+ case FIRST_LOCAL_BLOCK:
+ gdbscm_printf (port, " single block");
+ break;
+ }
+ }
+ else
+ gdbscm_printf (port, " !initialized");
+
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to create a <gdb:block-symbols-progress> object. */
+
+static SCM
+bkscm_make_block_syms_progress_smob (void)
+{
+ block_syms_progress_smob *i_smob = (block_syms_progress_smob *)
+ scm_gc_malloc (sizeof (block_syms_progress_smob),
+ block_syms_progress_smob_name);
+ SCM smob;
+
+ memset (&i_smob->iter, 0, sizeof (i_smob->iter));
+ i_smob->initialized_p = 0;
+ smob = scm_new_smob (block_syms_progress_smob_tag, (scm_t_bits) i_smob);
+ gdbscm_init_gsmob (&i_smob->base);
+
+ return smob;
+}
+
+/* Returns non-zero if SCM is a <gdb:block-symbols-progress> object. */
+
+static int
+bkscm_is_block_syms_progress (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (block_syms_progress_smob_tag, scm);
+}
+
+/* (block-symbols-progress? scm) -> boolean */
+
+static SCM
+bkscm_block_syms_progress_p (SCM scm)
+{
+ return scm_from_bool (bkscm_is_block_syms_progress (scm));
+}
+
+/* (make-block-symbols-iterator <gdb:block>) -> <gdb:iterator>
+ Return a <gdb:iterator> object for iterating over the symbols of SELF. */
+
+static SCM
+gdbscm_make_block_syms_iter (SCM self)
+{
+ block_smob *b_smob
+ = bkscm_get_valid_block_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct block *block = b_smob->block;
+ SCM progress, iter;
+
+ progress = bkscm_make_block_syms_progress_smob ();
+
+ iter = gdbscm_make_iterator (self, progress, bkscm_next_symbol_x_proc);
+
+ return iter;
+}
+
+/* Returns the next symbol in the iteration through the block's dictionary,
+ or (end-of-iteration).
+ This is the iterator_smob.next_x method. */
+
+static SCM
+gdbscm_block_next_symbol_x (SCM self)
+{
+ SCM progress, iter_scm, block_scm;
+ iterator_smob *iter_smob;
+ block_smob *b_smob;
+ const struct block *block;
+ block_syms_progress_smob *p_smob;
+ struct symbol *sym;
+
+ iter_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ iter_smob = (iterator_smob *) SCM_SMOB_DATA (iter_scm);
+
+ block_scm = itscm_iterator_smob_object (iter_smob);
+ b_smob = bkscm_get_valid_block_smob_arg_unsafe (block_scm,
+ SCM_ARG1, FUNC_NAME);
+ block = b_smob->block;
+
+ progress = itscm_iterator_smob_progress (iter_smob);
+
+ SCM_ASSERT_TYPE (bkscm_is_block_syms_progress (progress),
+ progress, SCM_ARG1, FUNC_NAME,
+ block_syms_progress_smob_name);
+ p_smob = (block_syms_progress_smob *) SCM_SMOB_DATA (progress);
+
+ if (!p_smob->initialized_p)
+ {
+ sym = block_iterator_first (block, &p_smob->iter);
+ p_smob->initialized_p = 1;
+ }
+ else
+ sym = block_iterator_next (&p_smob->iter);
+
+ if (sym == NULL)
+ return gdbscm_end_of_iteration ();
+
+ return syscm_scm_from_symbol (sym);
+}
+\f
+/* (lookup-block address) -> <gdb:block>
+ Returns the innermost lexical block containing the specified pc value,
+ or #f if there is none. */
+
+static SCM
+gdbscm_lookup_block (SCM pc_scm)
+{
+ CORE_ADDR pc;
+ struct block *block = NULL;
+ struct obj_section *section = NULL;
+ struct symtab *symtab = NULL;
+ volatile struct gdb_exception except;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "U", pc_scm, &pc);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ section = find_pc_mapped_section (pc);
+ symtab = find_pc_sect_symtab (pc, section);
+
+ if (symtab != NULL && symtab->objfile != NULL)
+ block = block_for_pc (pc);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (symtab == NULL || symtab->objfile == NULL)
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, pc_scm,
+ _("cannot locate object file for block"));
+ }
+
+ if (block != NULL)
+ return bkscm_scm_from_block (block, symtab->objfile);
+ return SCM_BOOL_F;
+}
+\f
+/* Initialize the Scheme block support. */
+
+static const scheme_function block_functions[] =
+{
+ { "block?", 1, 0, 0, gdbscm_block_p,
+ "\
+Return #t if the object is a <gdb:block> object." },
+
+ { "block-valid?", 1, 0, 0, gdbscm_block_valid_p,
+ "\
+Return #t if the block is valid.\n\
+A block becomes invalid when its objfile is freed." },
+
+ { "block-start", 1, 0, 0, gdbscm_block_start,
+ "\
+Return the start address of the block." },
+
+ { "block-end", 1, 0, 0, gdbscm_block_end,
+ "\
+Return the end address of the block." },
+
+ { "block-function", 1, 0, 0, gdbscm_block_function,
+ "\
+Return the gdb:symbol object of the function containing the block\n\
+or #f if the block does not live in any function." },
+
+ { "block-superblock", 1, 0, 0, gdbscm_block_superblock,
+ "\
+Return the superblock (parent block) of the block." },
+
+ { "block-global-block", 1, 0, 0, gdbscm_block_global_block,
+ "\
+Return the global block of the block." },
+
+ { "block-static-block", 1, 0, 0, gdbscm_block_static_block,
+ "\
+Return the static block of the block." },
+
+ { "block-global?", 1, 0, 0, gdbscm_block_global_p,
+ "\
+Return #t if block is a global block." },
+
+ { "block-static?", 1, 0, 0, gdbscm_block_static_p,
+ "\
+Return #t if block is a static block." },
+
+ { "block-symbols", 1, 0, 0, gdbscm_block_symbols,
+ "\
+Return a list of all symbols (as <gdb:symbol> objects) in the block." },
+
+ { "make-block-symbols-iterator", 1, 0, 0, gdbscm_make_block_syms_iter,
+ "\
+Return a <gdb:iterator> object for iterating over all symbols in the block." },
+
+ { "block-symbols-progress?", 1, 0, 0, bkscm_block_syms_progress_p,
+ "\
+Return #t if the object is a <gdb:block-symbols-progress> object." },
+
+ { "lookup-block", 1, 0, 0, gdbscm_lookup_block,
+ "\
+Return the innermost GDB block containing the address or #f if none found.\n\
+\n\
+ Arguments:\n\
+ address: the address to lookup" },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_blocks (void)
+{
+ block_smob_tag
+ = gdbscm_make_smob_type (block_smob_name, sizeof (block_smob));
+ scm_set_smob_mark (block_smob_tag, bkscm_mark_block_smob);
+ scm_set_smob_free (block_smob_tag, bkscm_free_block_smob);
+ scm_set_smob_print (block_smob_tag, bkscm_print_block_smob);
+
+ block_syms_progress_smob_tag
+ = gdbscm_make_smob_type (block_syms_progress_smob_name,
+ sizeof (block_syms_progress_smob));
+ scm_set_smob_mark (block_syms_progress_smob_tag,
+ bkscm_mark_block_syms_progress_smob);
+ scm_set_smob_print (block_syms_progress_smob_tag,
+ bkscm_print_block_syms_progress_smob);
+
+ gdbscm_define_functions (block_functions, 1);
+
+ /* This function is "private". */
+ bkscm_next_symbol_x_proc
+ = scm_c_define_gsubr ("%block-next-symbol!", 1, 0, 0,
+ gdbscm_block_next_symbol_x);
+ scm_set_procedure_property_x (bkscm_next_symbol_x_proc,
+ gdbscm_documentation_symbol,
+ gdbscm_scm_from_c_string ("\
+Internal function to assist the block symbols iterator."));
+
+ /* Register an objfile "free" callback so we can properly
+ invalidate blocks when an object file is about to be deleted. */
+ bkscm_objfile_data_key
+ = register_objfile_data_with_cleanup (NULL, bkscm_del_objfile_blocks);
+}
--- /dev/null
+/* Scheme interface to breakpoints.
+
+ 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 "value.h"
+#include "exceptions.h"
+#include "breakpoint.h"
+#include "gdbcmd.h"
+#include "gdbthread.h"
+#include "observer.h"
+#include "cli/cli-script.h"
+#include "ada-lang.h"
+#include "arch-utils.h"
+#include "language.h"
+#include "guile-internal.h"
+
+/* The <gdb:breakpoint> smob.
+ N.B.: The name of this struct is known to breakpoint.h. */
+
+typedef struct gdbscm_breakpoint_object
+{
+ /* This always appears first. */
+ gdb_smob base;
+
+ /* The breakpoint number according to gdb.
+ This is recorded here because BP will be NULL when deleted. */
+ int number;
+
+ /* The gdb breakpoint object, or NULL if the breakpoint has been deleted. */
+ struct breakpoint *bp;
+
+ /* Backlink to our containing <gdb:breakpoint> smob.
+ This is needed when we are deleted, we need to unprotect the object
+ from GC. */
+ SCM containing_scm;
+
+ /* A stop condition or #f. */
+ SCM stop;
+} breakpoint_smob;
+
+static const char breakpoint_smob_name[] = "gdb:breakpoint";
+
+/* The tag Guile knows the breakpoint smob by. */
+static scm_t_bits breakpoint_smob_tag;
+
+/* Variables used to pass information between the breakpoint_smob
+ constructor and the breakpoint-created hook function. */
+static SCM pending_breakpoint_scm = SCM_BOOL_F;
+
+/* Keywords used by create-breakpoint!. */
+static SCM type_keyword;
+static SCM wp_class_keyword;
+static SCM internal_keyword;
+\f
+/* Administrivia for breakpoint smobs. */
+
+/* The smob "mark" function for <gdb:breakpoint>. */
+
+static SCM
+bpscm_mark_breakpoint_smob (SCM self)
+{
+ breakpoint_smob *bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (self);
+
+ /* We don't mark containing_scm here. It is just a backlink to our
+ container, and is gc'protected until the breakpoint is deleted. */
+
+ scm_gc_mark (bp_smob->stop);
+
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&bp_smob->base);
+}
+
+/* The smob "free" function for <gdb:breakpoint>. */
+
+static size_t
+bpscm_free_breakpoint_smob (SCM self)
+{
+ breakpoint_smob *bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (self);
+
+ if (bp_smob->bp)
+ bp_smob->bp->scm_bp_object = NULL;
+
+ /* Not necessary, done to catch bugs. */
+ bp_smob->bp = NULL;
+ bp_smob->containing_scm = SCM_UNDEFINED;
+ bp_smob->stop = SCM_UNDEFINED;
+
+ return 0;
+}
+
+/* Return the name of TYPE.
+ This doesn't handle all types, just the ones we export. */
+
+static const char *
+bpscm_type_to_string (enum bptype type)
+{
+ switch (type)
+ {
+ case bp_none: return "BP_NONE";
+ case bp_breakpoint: return "BP_BREAKPOINT";
+ case bp_watchpoint: return "BP_WATCHPOINT";
+ case bp_hardware_watchpoint: return "BP_HARDWARE_WATCHPOINT";
+ case bp_read_watchpoint: return "BP_READ_WATCHPOINT";
+ case bp_access_watchpoint: return "BP_ACCESS_WATCHPOINT";
+ default: return "internal/other";
+ }
+}
+
+/* Return the name of ENABLE_STATE. */
+
+static const char *
+bpscm_enable_state_to_string (enum enable_state enable_state)
+{
+ switch (enable_state)
+ {
+ case bp_disabled: return "disabled";
+ case bp_enabled: return "enabled";
+ case bp_call_disabled: return "call_disabled";
+ case bp_permanent: return "permanent";
+ default: return "unknown";
+ }
+}
+
+/* The smob "print" function for <gdb:breakpoint>. */
+
+static int
+bpscm_print_breakpoint_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ breakpoint_smob *bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (self);
+ struct breakpoint *b = bp_smob->bp;
+
+ gdbscm_printf (port, "#<%s", breakpoint_smob_name);
+
+ /* Only print what we export to the user.
+ The rest are possibly internal implementation details. */
+
+ gdbscm_printf (port, " #%d", bp_smob->number);
+
+ /* Careful, the breakpoint may be invalid. */
+ if (b != NULL)
+ {
+ gdbscm_printf (port, " %s %s %s",
+ bpscm_type_to_string (b->type),
+ bpscm_enable_state_to_string (b->enable_state),
+ b->silent ? "silent" : "noisy");
+
+ gdbscm_printf (port, " hit:%d", b->hit_count);
+ gdbscm_printf (port, " ignore:%d", b->ignore_count);
+
+ if (b->addr_string != NULL)
+ gdbscm_printf (port, " @%s", b->addr_string);
+ }
+
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to create a <gdb:breakpoint> object. */
+
+static SCM
+bpscm_make_breakpoint_smob (void)
+{
+ breakpoint_smob *bp_smob = (breakpoint_smob *)
+ scm_gc_malloc (sizeof (breakpoint_smob), breakpoint_smob_name);
+ SCM bp_scm;
+
+ bp_smob->number = -1;
+ bp_smob->bp = NULL;
+ bp_smob->stop = SCM_BOOL_F;
+ bp_scm = scm_new_smob (breakpoint_smob_tag, (scm_t_bits) bp_smob);
+ bp_smob->containing_scm = bp_scm;
+ gdbscm_init_gsmob (&bp_smob->base);
+
+ return bp_scm;
+}
+
+/* Return non-zero if we want a Scheme wrapper for breakpoint B.
+ If FROM_SCHEME is non-zero,this is called for a breakpoint created
+ by the user from Scheme. Otherwise it is zero. */
+
+static int
+bpscm_want_scm_wrapper_p (struct breakpoint *bp, int from_scheme)
+{
+ /* Don't create <gdb:breakpoint> objects for internal GDB breakpoints. */
+ if (bp->number < 0 && !from_scheme)
+ return 0;
+
+ /* The others are not supported. */
+ if (bp->type != bp_breakpoint
+ && bp->type != bp_watchpoint
+ && bp->type != bp_hardware_watchpoint
+ && bp->type != bp_read_watchpoint
+ && bp->type != bp_access_watchpoint)
+ return 0;
+
+ return 1;
+}
+
+/* Install the Scheme side of a breakpoint, CONTAINING_SCM, in
+ the gdb side BP. */
+
+static void
+bpscm_attach_scm_to_breakpoint (struct breakpoint *bp, SCM containing_scm)
+{
+ breakpoint_smob *bp_smob;
+
+ bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (containing_scm);
+ bp_smob->number = bp->number;
+ bp_smob->bp = bp;
+ bp_smob->containing_scm = containing_scm;
+ bp_smob->bp->scm_bp_object = bp_smob;
+
+ /* The owner of this breakpoint is not in GC-controlled memory, so we need
+ to protect it from GC until the breakpoint is deleted. */
+ scm_gc_protect_object (containing_scm);
+}
+
+/* Return non-zero if SCM is a breakpoint smob. */
+
+static int
+bpscm_is_breakpoint (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (breakpoint_smob_tag, scm);
+}
+
+/* (breakpoint? scm) -> boolean */
+
+static SCM
+gdbscm_breakpoint_p (SCM scm)
+{
+ return scm_from_bool (bpscm_is_breakpoint (scm));
+}
+
+/* Returns the <gdb:breakpoint> object in SELF.
+ Throws an exception if SELF is not a <gdb:breakpoint> object. */
+
+static SCM
+bpscm_get_breakpoint_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (bpscm_is_breakpoint (self), self, arg_pos, func_name,
+ breakpoint_smob_name);
+
+ return self;
+}
+
+/* Returns a pointer to the breakpoint smob of SELF.
+ Throws an exception if SELF is not a <gdb:breakpoint> object. */
+
+static breakpoint_smob *
+bpscm_get_breakpoint_smob_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ SCM bp_scm = bpscm_get_breakpoint_arg_unsafe (self, arg_pos, func_name);
+ breakpoint_smob *bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (bp_scm);
+
+ return bp_smob;
+}
+
+/* Return non-zero if breakpoint BP_SMOB is valid. */
+
+static int
+bpscm_is_valid (breakpoint_smob *bp_smob)
+{
+ return bp_smob->bp != NULL;
+}
+
+/* Returns the breakpoint smob in SELF, verifying it's valid.
+ Throws an exception if SELF is not a <gdb:breakpoint> object,
+ or is invalid. */
+
+static breakpoint_smob *
+bpscm_get_valid_breakpoint_smob_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_breakpoint_smob_arg_unsafe (self, arg_pos, func_name);
+
+ if (!bpscm_is_valid (bp_smob))
+ {
+ gdbscm_invalid_object_error (func_name, arg_pos, self,
+ _("<gdb:breakpoint>"));
+ }
+
+ return bp_smob;
+}
+\f
+/* Breakpoint methods. */
+
+/* (create-breakpoint! string [#:type integer] [#:wp-class integer]
+ [#:internal boolean) -> <gdb:breakpoint> */
+
+static SCM
+gdbscm_create_breakpoint_x (SCM spec_scm, SCM rest)
+{
+ const SCM keywords[] = {
+ type_keyword, wp_class_keyword, internal_keyword, SCM_BOOL_F
+ };
+ char *spec;
+ int type_arg_pos = -1, access_type_arg_pos = -1, internal_arg_pos = -1;
+ int type = bp_breakpoint;
+ int access_type = hw_write;
+ int internal = 0;
+ SCM result;
+ volatile struct gdb_exception except;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#iit",
+ spec_scm, &spec, rest,
+ &type_arg_pos, &type,
+ &access_type_arg_pos, &access_type,
+ &internal_arg_pos, &internal);
+
+ result = bpscm_make_breakpoint_smob ();
+ pending_breakpoint_scm = result;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct cleanup *cleanup = make_cleanup (xfree, spec);
+
+ switch (type)
+ {
+ case bp_breakpoint:
+ {
+ create_breakpoint (get_current_arch (),
+ spec, NULL, -1, NULL,
+ 0,
+ 0, bp_breakpoint,
+ 0,
+ AUTO_BOOLEAN_TRUE,
+ &bkpt_breakpoint_ops,
+ 0, 1, internal, 0);
+ break;
+ }
+ case bp_watchpoint:
+ {
+ if (access_type == hw_write)
+ watch_command_wrapper (spec, 0, internal);
+ else if (access_type == hw_access)
+ awatch_command_wrapper (spec, 0, internal);
+ else if (access_type == hw_read)
+ rwatch_command_wrapper (spec, 0, internal);
+ else
+ error (_("Invalid watchpoint access type"));
+ break;
+ }
+ default:
+ error (_("Invalid breakpoint type"));
+ }
+
+ do_cleanups (cleanup);
+ }
+ /* Ensure this gets reset, even if there's an error. */
+ pending_breakpoint_scm = SCM_BOOL_F;
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return result;
+}
+
+/* (breakpoint-delete! <gdb:breakpoint>) -> unspecified
+ Scheme function which deletes the underlying GDB breakpoint. This
+ triggers the breakpoint_deleted observer which will call
+ gdbscm_breakpoint_deleted; that function cleans up the Scheme sections. */
+
+static SCM
+gdbscm_breakpoint_delete_x (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ delete_breakpoint (bp_smob->bp);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return SCM_UNSPECIFIED;
+}
+
+/* iterate_over_breakpoints function for gdbscm_breakpoints. */
+
+static int
+bpscm_build_bp_list (struct breakpoint *bp, void *arg)
+{
+ SCM *list = arg;
+ breakpoint_smob *bp_smob = bp->scm_bp_object;
+
+ /* Lazily create wrappers for breakpoints created outside Scheme. */
+
+ if (bp_smob == NULL)
+ {
+ if (bpscm_want_scm_wrapper_p (bp, 0))
+ {
+ SCM bp_scm;
+
+ bp_scm = bpscm_make_breakpoint_smob ();
+ bpscm_attach_scm_to_breakpoint (bp, bp_scm);
+ /* Refetch it. */
+ bp_smob = bp->scm_bp_object;
+ }
+ }
+
+ /* Not all breakpoints will have a companion Scheme object.
+ Only breakpoints that trigger the created_breakpoint observer call,
+ and satisfy certain conditions (see bpscm_want_scm_wrapper_p),
+ get a companion object (this includes Scheme-created breakpoints). */
+
+ if (bp_smob != NULL)
+ *list = scm_cons (bp_smob->containing_scm, *list);
+
+ return 0;
+}
+
+/* (breakpoints) -> list
+ Return a list of all breakpoints. */
+
+static SCM
+gdbscm_breakpoints (void)
+{
+ SCM list = SCM_EOL;
+
+ /* If iterate_over_breakpoints returns non-NULL it means the iteration
+ terminated early.
+ In that case abandon building the list and return #f. */
+ if (iterate_over_breakpoints (bpscm_build_bp_list, &list) != NULL)
+ return SCM_BOOL_F;
+
+ return scm_reverse_x (list, SCM_EOL);
+}
+
+/* (breakpoint-valid? <gdb:breakpoint>) -> boolean
+ Returns #t if SELF is still valid. */
+
+static SCM
+gdbscm_breakpoint_valid_p (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_bool (bpscm_is_valid (bp_smob));
+}
+
+/* (breakpoint-enabled? <gdb:breakpoint>) -> boolean */
+
+static SCM
+gdbscm_breakpoint_enabled_p (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_bool (bp_smob->bp->enable_state == bp_enabled);
+}
+
+/* (set-breakpoint-enabled? <gdb:breakpoint> boolean) -> unspecified */
+
+static SCM
+gdbscm_set_breakpoint_enabled_x (SCM self, SCM newvalue)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ volatile struct gdb_exception except;
+
+ SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue), newvalue, SCM_ARG2, FUNC_NAME,
+ _("boolean"));
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (gdbscm_is_true (newvalue))
+ enable_breakpoint (bp_smob->bp);
+ else
+ disable_breakpoint (bp_smob->bp);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return SCM_UNSPECIFIED;
+}
+
+/* (breakpoint-silent? <gdb:breakpoint>) -> boolean */
+
+static SCM
+gdbscm_breakpoint_silent_p (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_bool (bp_smob->bp->silent);
+}
+
+/* (set-breakpoint-silent?! <gdb:breakpoint> boolean) -> unspecified */
+
+static SCM
+gdbscm_set_breakpoint_silent_x (SCM self, SCM newvalue)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ volatile struct gdb_exception except;
+
+ SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue), newvalue, SCM_ARG2, FUNC_NAME,
+ _("boolean"));
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ breakpoint_set_silent (bp_smob->bp, gdbscm_is_true (newvalue));
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return SCM_UNSPECIFIED;
+}
+
+/* (breakpoint-ignore-count <gdb:breakpoint>) -> integer */
+
+static SCM
+gdbscm_breakpoint_ignore_count (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_long (bp_smob->bp->ignore_count);
+}
+
+/* (set-breakpoint-ignore-count! <gdb:breakpoint> integer)
+ -> unspecified */
+
+static SCM
+gdbscm_set_breakpoint_ignore_count_x (SCM self, SCM newvalue)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ long value;
+ volatile struct gdb_exception except;
+
+ SCM_ASSERT_TYPE (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX),
+ newvalue, SCM_ARG2, FUNC_NAME, _("integer"));
+
+ value = scm_to_long (newvalue);
+ if (value < 0)
+ value = 0;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ set_ignore_count (bp_smob->number, (int) value, 0);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return SCM_UNSPECIFIED;
+}
+
+/* (breakpoint-hit-count <gdb:breakpoint>) -> integer */
+
+static SCM
+gdbscm_breakpoint_hit_count (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_long (bp_smob->bp->hit_count);
+}
+
+/* (set-breakpoint-hit-count! <gdb:breakpoint> integer) -> unspecified */
+
+static SCM
+gdbscm_set_breakpoint_hit_count_x (SCM self, SCM newvalue)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ long value;
+
+ SCM_ASSERT_TYPE (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX),
+ newvalue, SCM_ARG2, FUNC_NAME, _("integer"));
+
+ value = scm_to_long (newvalue);
+ if (value < 0)
+ value = 0;
+
+ if (value != 0)
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue,
+ _("hit-count must be zero"));
+ }
+
+ bp_smob->bp->hit_count = 0;
+
+ return SCM_UNSPECIFIED;
+}
+
+/* (breakpoint-thread <gdb:breakpoint>) -> integer */
+
+static SCM
+gdbscm_breakpoint_thread (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ if (bp_smob->bp->thread == -1)
+ return SCM_BOOL_F;
+
+ return scm_from_long (bp_smob->bp->thread);
+}
+
+/* (set-breakpoint-thread! <gdb:breakpoint> integer) -> unspecified */
+
+static SCM
+gdbscm_set_breakpoint_thread_x (SCM self, SCM newvalue)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ long id;
+
+ if (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX))
+ {
+ id = scm_to_long (newvalue);
+ if (! valid_thread_id (id))
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue,
+ _("invalid thread id"));
+ }
+ }
+ else if (gdbscm_is_false (newvalue))
+ id = -1;
+ else
+ SCM_ASSERT_TYPE (0, newvalue, SCM_ARG2, FUNC_NAME, _("integer or #f"));
+
+ breakpoint_set_thread (bp_smob->bp, id);
+
+ return SCM_UNSPECIFIED;
+}
+
+/* (breakpoint-task <gdb:breakpoint>) -> integer */
+
+static SCM
+gdbscm_breakpoint_task (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ if (bp_smob->bp->task == 0)
+ return SCM_BOOL_F;
+
+ return scm_from_long (bp_smob->bp->task);
+}
+
+/* (set-breakpoint-task! <gdb:breakpoint> integer) -> unspecified */
+
+static SCM
+gdbscm_set_breakpoint_task_x (SCM self, SCM newvalue)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ long id;
+ int valid_id = 0;
+ volatile struct gdb_exception except;
+
+ if (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX))
+ {
+ id = scm_to_long (newvalue);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ valid_id = valid_task_id (id);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (! valid_id)
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, newvalue,
+ _("invalid task id"));
+ }
+ }
+ else if (gdbscm_is_false (newvalue))
+ id = 0;
+ else
+ SCM_ASSERT_TYPE (0, newvalue, SCM_ARG2, FUNC_NAME, _("integer or #f"));
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ breakpoint_set_task (bp_smob->bp, id);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return SCM_UNSPECIFIED;
+}
+
+/* (breakpoint-location <gdb:breakpoint>) -> string */
+
+static SCM
+gdbscm_breakpoint_location (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ char *str;
+
+ if (bp_smob->bp->type != bp_breakpoint)
+ return SCM_BOOL_F;
+
+ str = bp_smob->bp->addr_string;
+ if (! str)
+ str = "";
+
+ return gdbscm_scm_from_c_string (str);
+}
+
+/* (breakpoint-expression <gdb:breakpoint>) -> string
+ This is only valid for watchpoints.
+ Returns #f for non-watchpoints. */
+
+static SCM
+gdbscm_breakpoint_expression (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ char *str;
+ struct watchpoint *wp;
+
+ if (!is_watchpoint (bp_smob->bp))
+ return SCM_BOOL_F;
+
+ wp = (struct watchpoint *) bp_smob->bp;
+
+ str = wp->exp_string;
+ if (! str)
+ str = "";
+
+ return gdbscm_scm_from_c_string (str);
+}
+
+/* (breakpoint-condition <gdb:breakpoint>) -> string */
+
+static SCM
+gdbscm_breakpoint_condition (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ char *str;
+
+ str = bp_smob->bp->cond_string;
+ if (! str)
+ return SCM_BOOL_F;
+
+ return gdbscm_scm_from_c_string (str);
+}
+
+/* (set-breakpoint-condition! <gdb:breakpoint> string|#f)
+ -> unspecified */
+
+static SCM
+gdbscm_set_breakpoint_condition_x (SCM self, SCM newvalue)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ char *exp;
+ volatile struct gdb_exception except;
+
+ SCM_ASSERT_TYPE (scm_is_string (newvalue) || gdbscm_is_false (newvalue),
+ newvalue, SCM_ARG2, FUNC_NAME,
+ _("string or #f"));
+
+ if (gdbscm_is_false (newvalue))
+ exp = NULL;
+ else
+ exp = gdbscm_scm_to_c_string (newvalue);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ set_breakpoint_condition (bp_smob->bp, exp ? exp : "", 0);
+ }
+ xfree (exp);
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return SCM_UNSPECIFIED;
+}
+
+/* (breakpoint-stop <gdb:breakpoint>) -> procedure or #f */
+
+static SCM
+gdbscm_breakpoint_stop (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return bp_smob->stop;
+}
+
+/* (set-breakpoint-stop! <gdb:breakpoint> procedure|#f)
+ -> unspecified */
+
+static SCM
+gdbscm_set_breakpoint_stop_x (SCM self, SCM newvalue)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct extension_language_defn *extlang = NULL;
+
+ SCM_ASSERT_TYPE (gdbscm_is_procedure (newvalue)
+ || gdbscm_is_false (newvalue),
+ newvalue, SCM_ARG2, FUNC_NAME,
+ _("procedure or #f"));
+
+ if (bp_smob->bp->cond_string != NULL)
+ extlang = get_ext_lang_defn (EXT_LANG_GDB);
+ if (extlang == NULL)
+ extlang = get_breakpoint_cond_ext_lang (bp_smob->bp, EXT_LANG_GUILE);
+ if (extlang != NULL)
+ {
+ char *error_text
+ = xstrprintf (_("Only one stop condition allowed. There is"
+ " currently a %s stop condition defined for"
+ " this breakpoint."),
+ ext_lang_capitalized_name (extlang));
+
+ scm_dynwind_begin (0);
+ gdbscm_dynwind_xfree (error_text);
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self, error_text);
+ /* The following line, while unnecessary, is present for completeness
+ sake. */
+ scm_dynwind_end ();
+ }
+
+ bp_smob->stop = newvalue;
+
+ return SCM_UNSPECIFIED;
+}
+
+/* (breakpoint-commands <gdb:breakpoint>) -> string */
+
+static SCM
+gdbscm_breakpoint_commands (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct breakpoint *bp;
+ long length;
+ volatile struct gdb_exception except;
+ struct ui_file *string_file;
+ struct cleanup *chain;
+ SCM result;
+ char *cmdstr;
+
+ bp = bp_smob->bp;
+
+ if (bp->commands == NULL)
+ return SCM_BOOL_F;
+
+ string_file = mem_fileopen ();
+ chain = make_cleanup_ui_file_delete (string_file);
+
+ ui_out_redirect (current_uiout, string_file);
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ print_command_lines (current_uiout, breakpoint_commands (bp), 0);
+ }
+ ui_out_redirect (current_uiout, NULL);
+ if (except.reason < 0)
+ {
+ do_cleanups (chain);
+ gdbscm_throw_gdb_exception (except);
+ }
+
+ cmdstr = ui_file_xstrdup (string_file, &length);
+ make_cleanup (xfree, cmdstr);
+ result = gdbscm_scm_from_c_string (cmdstr);
+
+ do_cleanups (chain);
+ return result;
+}
+
+/* (breakpoint-type <gdb:breakpoint>) -> integer */
+
+static SCM
+gdbscm_breakpoint_type (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_long (bp_smob->bp->type);
+}
+
+/* (breakpoint-visible? <gdb:breakpoint>) -> boolean */
+
+static SCM
+gdbscm_breakpoint_visible (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_bool (bp_smob->bp->number >= 0);
+}
+
+/* (breakpoint-number <gdb:breakpoint>) -> integer */
+
+static SCM
+gdbscm_breakpoint_number (SCM self)
+{
+ breakpoint_smob *bp_smob
+ = bpscm_get_valid_breakpoint_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_long (bp_smob->number);
+}
+\f
+/* Return TRUE if "stop" has been set for this breakpoint.
+
+ This is the extension_language_ops.breakpoint_has_cond "method". */
+
+int
+gdbscm_breakpoint_has_cond (const struct extension_language_defn *extlang,
+ struct breakpoint *b)
+{
+ breakpoint_smob *bp_smob = b->scm_bp_object;
+
+ if (bp_smob == NULL)
+ return 0;
+
+ return gdbscm_is_procedure (bp_smob->stop);
+}
+
+/* Call the "stop" method in the breakpoint class.
+ This must only be called if gdbscm_breakpoint_has_cond returns true.
+ If the stop method returns #t, the inferior will be stopped at the
+ breakpoint. Otherwise the inferior will be allowed to continue
+ (assuming other conditions don't indicate "stop").
+
+ This is the extension_language_ops.breakpoint_cond_says_stop "method". */
+
+enum ext_lang_bp_stop
+gdbscm_breakpoint_cond_says_stop
+ (const struct extension_language_defn *extlang, struct breakpoint *b)
+{
+ breakpoint_smob *bp_smob = b->scm_bp_object;
+ SCM predicate_result;
+ int stop;
+
+ if (bp_smob == NULL)
+ return EXT_LANG_BP_STOP_UNSET;
+ if (!gdbscm_is_procedure (bp_smob->stop))
+ return EXT_LANG_BP_STOP_UNSET;
+
+ stop = 1;
+
+ predicate_result
+ = gdbscm_safe_call_1 (bp_smob->stop, bp_smob->containing_scm, NULL);
+
+ if (gdbscm_is_exception (predicate_result))
+ ; /* Exception already printed. */
+ /* If the "stop" function returns #f that means
+ the Scheme breakpoint wants GDB to continue. */
+ else if (gdbscm_is_false (predicate_result))
+ stop = 0;
+
+ return stop ? EXT_LANG_BP_STOP_YES : EXT_LANG_BP_STOP_NO;
+}
+\f
+/* Event callback functions. */
+
+/* Callback that is used when a breakpoint is created.
+ For breakpoints created by Scheme, i.e., gdbscm_create_breakpoint_x, finish
+ object creation by connecting the Scheme wrapper to the gdb object.
+ We ignore breakpoints created from gdb or python here, we create the
+ Scheme wrapper for those when there's a need to, e.g.,
+ gdbscm_breakpoints. */
+
+static void
+bpscm_breakpoint_created (struct breakpoint *bp)
+{
+ SCM bp_scm;
+
+ if (gdbscm_is_false (pending_breakpoint_scm))
+ return;
+
+ /* Verify our caller error checked the user's request. */
+ gdb_assert (bpscm_want_scm_wrapper_p (bp, 1));
+
+ bp_scm = pending_breakpoint_scm;
+ pending_breakpoint_scm = SCM_BOOL_F;
+
+ bpscm_attach_scm_to_breakpoint (bp, bp_scm);
+}
+
+/* Callback that is used when a breakpoint is deleted. This will
+ invalidate the corresponding Scheme object. */
+
+static void
+bpscm_breakpoint_deleted (struct breakpoint *b)
+{
+ int num = b->number;
+ struct breakpoint *bp;
+
+ /* TODO: Why the lookup? We have B. */
+
+ bp = get_breakpoint (num);
+ if (bp)
+ {
+ breakpoint_smob *bp_smob = bp->scm_bp_object;
+
+ if (bp_smob)
+ {
+ bp_smob->bp = NULL;
+ scm_gc_unprotect_object (bp_smob->containing_scm);
+ }
+ }
+}
+\f
+/* Initialize the Scheme breakpoint code. */
+
+static const scheme_integer_constant breakpoint_integer_constants[] =
+{
+ { "BP_NONE", bp_none },
+ { "BP_BREAKPOINT", bp_breakpoint },
+ { "BP_WATCHPOINT", bp_watchpoint },
+ { "BP_HARDWARE_WATCHPOINT", bp_hardware_watchpoint },
+ { "BP_READ_WATCHPOINT", bp_read_watchpoint },
+ { "BP_ACCESS_WATCHPOINT", bp_access_watchpoint },
+
+ { "WP_READ", hw_read },
+ { "WP_WRITE", hw_write },
+ { "WP_ACCESS", hw_access },
+
+ END_INTEGER_CONSTANTS
+};
+
+static const scheme_function breakpoint_functions[] =
+{
+ { "create-breakpoint!", 1, 0, 1, gdbscm_create_breakpoint_x,
+ "\
+Create and install a GDB breakpoint object.\n\
+\n\
+ Arguments:\n\
+ location [#:type <type>] [#:wp-class <wp-class>] [#:internal <bool>]" },
+
+ { "breakpoint-delete!", 1, 0, 0, gdbscm_breakpoint_delete_x,
+ "\
+Delete the breakpoint from GDB." },
+
+ { "breakpoints", 0, 0, 0, gdbscm_breakpoints,
+ "\
+Return a list of all GDB breakpoints.\n\
+\n\
+ Arguments: none" },
+
+ { "breakpoint?", 1, 0, 0, gdbscm_breakpoint_p,
+ "\
+Return #t if the object is a <gdb:breakpoint> object." },
+
+ { "breakpoint-valid?", 1, 0, 0, gdbscm_breakpoint_valid_p,
+ "\
+Return #t if the breakpoint has not been deleted from GDB." },
+
+ { "breakpoint-number", 1, 0, 0, gdbscm_breakpoint_number,
+ "\
+Return the breakpoint's number." },
+
+ { "breakpoint-type", 1, 0, 0, gdbscm_breakpoint_type,
+ "\
+Return the type of the breakpoint." },
+
+ { "breakpoint-visible?", 1, 0, 0, gdbscm_breakpoint_visible,
+ "\
+Return #t if the breakpoint is visible to the user." },
+
+ { "breakpoint-location", 1, 0, 0, gdbscm_breakpoint_location,
+ "\
+Return the location of the breakpoint as specified by the user." },
+
+ { "breakpoint-expression", 1, 0, 0, gdbscm_breakpoint_expression,
+ "\
+Return the expression of the breakpoint as specified by the user.\n\
+Valid for watchpoints only, returns #f for non-watchpoints." },
+
+ { "breakpoint-enabled?", 1, 0, 0, gdbscm_breakpoint_enabled_p,
+ "\
+Return #t if the breakpoint is enabled." },
+
+ { "set-breakpoint-enabled!", 2, 0, 0, gdbscm_set_breakpoint_enabled_x,
+ "\
+Set the breakpoint's enabled state.\n\
+\n\
+ Arguments: <gdb:breakpoint boolean" },
+
+ { "breakpoint-silent?", 1, 0, 0, gdbscm_breakpoint_silent_p,
+ "\
+Return #t if the breakpoint is silent." },
+
+ { "set-breakpoint-silent!", 2, 0, 0, gdbscm_set_breakpoint_silent_x,
+ "\
+Set the breakpoint's silent state.\n\
+\n\
+ Arguments: <gdb:breakpoint> boolean" },
+
+ { "breakpoint-ignore-count", 1, 0, 0, gdbscm_breakpoint_ignore_count,
+ "\
+Return the breakpoint's \"ignore\" count." },
+
+ { "set-breakpoint-ignore-count!", 2, 0, 0,
+ gdbscm_set_breakpoint_ignore_count_x,
+ "\
+Set the breakpoint's \"ignore\" count.\n\
+\n\
+ Arguments: <gdb:breakpoint> count" },
+
+ { "breakpoint-hit-count", 1, 0, 0, gdbscm_breakpoint_hit_count,
+ "\
+Return the breakpoint's \"hit\" count." },
+
+ { "set-breakpoint-hit-count!", 2, 0, 0, gdbscm_set_breakpoint_hit_count_x,
+ "\
+Set the breakpoint's \"hit\" count. The value must be zero.\n\
+\n\
+ Arguments: <gdb:breakpoint> 0" },
+
+ { "breakpoint-thread", 1, 0, 0, gdbscm_breakpoint_thread,
+ "\
+Return the breakpoint's thread id or #f if there isn't one." },
+
+ { "set-breakpoint-thread!", 2, 0, 0, gdbscm_set_breakpoint_thread_x,
+ "\
+Set the thread id for this breakpoint.\n\
+\n\
+ Arguments: <gdb:breakpoint> thread-id" },
+
+ { "breakpoint-task", 1, 0, 0, gdbscm_breakpoint_task,
+ "\
+Return the breakpoint's Ada task-id or #f if there isn't one." },
+
+ { "set-breakpoint-task!", 2, 0, 0, gdbscm_set_breakpoint_task_x,
+ "\
+Set the breakpoint's Ada task-id.\n\
+\n\
+ Arguments: <gdb:breakpoint> task-id" },
+
+ { "breakpoint-condition", 1, 0, 0, gdbscm_breakpoint_condition,
+ "\
+Return the breakpoint's condition as specified by the user.\n\
+Return #f if there isn't one." },
+
+ { "set-breakpoint-condition!", 2, 0, 0, gdbscm_set_breakpoint_condition_x,
+ "\
+Set the breakpoint's condition.\n\
+\n\
+ Arguments: <gdb:breakpoint> condition\n\
+ condition: a string" },
+
+ { "breakpoint-stop", 1, 0, 0, gdbscm_breakpoint_stop,
+ "\
+Return the breakpoint's stop predicate.\n\
+Return #f if there isn't one." },
+
+ { "set-breakpoint-stop!", 2, 0, 0, gdbscm_set_breakpoint_stop_x,
+ "\
+Set the breakpoint's stop predicate.\n\
+\n\
+ Arguments: <gdb:breakpoint> procedure\n\
+ procedure: A procedure of one argument, the breakpoint.\n\
+ Its result is true if program execution should stop." },
+
+ { "breakpoint-commands", 1, 0, 0, gdbscm_breakpoint_commands,
+ "\
+Return the breakpoint's commands." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_breakpoints (void)
+{
+ breakpoint_smob_tag
+ = gdbscm_make_smob_type (breakpoint_smob_name, sizeof (breakpoint_smob));
+ scm_set_smob_mark (breakpoint_smob_tag, bpscm_mark_breakpoint_smob);
+ scm_set_smob_free (breakpoint_smob_tag, bpscm_free_breakpoint_smob);
+ scm_set_smob_print (breakpoint_smob_tag, bpscm_print_breakpoint_smob);
+
+ observer_attach_breakpoint_created (bpscm_breakpoint_created);
+ observer_attach_breakpoint_deleted (bpscm_breakpoint_deleted);
+
+ gdbscm_define_integer_constants (breakpoint_integer_constants, 1);
+ gdbscm_define_functions (breakpoint_functions, 1);
+
+ type_keyword = scm_from_latin1_keyword ("type");
+ wp_class_keyword = scm_from_latin1_keyword ("wp-class");
+ internal_keyword = scm_from_latin1_keyword ("internal");
+}
--- /dev/null
+/* Scheme interface to architecture.
+
+ Copyright (C) 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 "arch-utils.h"
+#include "disasm.h"
+#include "dis-asm.h"
+#include "gdbarch.h"
+#include "gdbcore.h" /* Why is memory_error here? */
+#include "guile-internal.h"
+
+static SCM port_keyword;
+static SCM offset_keyword;
+static SCM size_keyword;
+static SCM count_keyword;
+
+static SCM address_symbol;
+static SCM asm_symbol;
+static SCM length_symbol;
+
+/* Struct used to pass "application data" in disassemble_info. */
+
+struct gdbscm_disasm_data
+{
+ struct gdbarch *gdbarch;
+ SCM port;
+ /* The offset of the address of the first instruction in PORT. */
+ ULONGEST offset;
+};
+
+/* Struct used to pass data from gdbscm_disasm_read_memory to
+ gdbscm_disasm_read_memory_worker. */
+
+struct gdbscm_disasm_read_data
+{
+ bfd_vma memaddr;
+ bfd_byte *myaddr;
+ unsigned int length;
+ struct disassemble_info *dinfo;
+};
+\f
+/* Subroutine of gdbscm_arch_disassemble to simplify it.
+ Return the result for one instruction. */
+
+static SCM
+dascm_make_insn (CORE_ADDR pc, const char *assembly, int insn_len)
+{
+ return scm_list_3 (scm_cons (address_symbol,
+ gdbscm_scm_from_ulongest (pc)),
+ scm_cons (asm_symbol,
+ gdbscm_scm_from_c_string (assembly)),
+ scm_cons (length_symbol,
+ scm_from_int (insn_len)));
+}
+
+/* Helper function for gdbscm_disasm_read_memory to safely read from a
+ Scheme port. Called via gdbscm_call_guile.
+ The result is a statically allocated error message or NULL if success. */
+
+static void *
+gdbscm_disasm_read_memory_worker (void *datap)
+{
+ struct gdbscm_disasm_read_data *data = datap;
+ struct disassemble_info *dinfo = data->dinfo;
+ struct gdbscm_disasm_data *disasm_data = dinfo->application_data;
+ SCM seekto, newpos, port = disasm_data->port;
+ size_t bytes_read;
+
+ seekto = gdbscm_scm_from_ulongest (data->memaddr - disasm_data->offset);
+ newpos = scm_seek (port, seekto, scm_from_int (SEEK_SET));
+ if (!scm_is_eq (seekto, newpos))
+ return "seek error";
+
+ bytes_read = scm_c_read (port, data->myaddr, data->length);
+
+ if (bytes_read != data->length)
+ return "short read";
+
+ /* If we get here the read succeeded. */
+ return NULL;
+}
+
+/* disassemble_info.read_memory_func for gdbscm_print_insn_from_port. */
+
+static int
+gdbscm_disasm_read_memory (bfd_vma memaddr, bfd_byte *myaddr,
+ unsigned int length,
+ struct disassemble_info *dinfo)
+{
+ struct gdbscm_disasm_read_data data;
+ void *status;
+
+ data.memaddr = memaddr;
+ data.myaddr = myaddr;
+ data.length = length;
+ data.dinfo = dinfo;
+
+ status = gdbscm_with_guile (gdbscm_disasm_read_memory_worker, &data);
+
+ /* TODO: IWBN to distinguish problems reading target memory versus problems
+ with the port (e.g., EOF).
+ We return TARGET_XFER_E_IO here as that's what memory_error looks for. */
+ return status != NULL ? TARGET_XFER_E_IO : 0;
+}
+
+/* disassemble_info.memory_error_func for gdbscm_print_insn_from_port.
+ Technically speaking, we don't need our own memory_error_func,
+ but to not provide one would leave a subtle dependency in the code.
+ This function exists to keep a clear boundary. */
+
+static void
+gdbscm_disasm_memory_error (int status, bfd_vma memaddr,
+ struct disassemble_info *info)
+{
+ memory_error (status, memaddr);
+}
+
+/* disassemble_info.print_address_func for gdbscm_print_insn_from_port.
+ Since we need to use our own application_data value, we need to supply
+ this routine as well. */
+
+static void
+gdbscm_disasm_print_address (bfd_vma addr, struct disassemble_info *info)
+{
+ struct gdbscm_disasm_data *data = info->application_data;
+ struct gdbarch *gdbarch = data->gdbarch;
+
+ print_address (gdbarch, addr, info->stream);
+}
+
+/* Subroutine of gdbscm_arch_disassemble to simplify it.
+ Call gdbarch_print_insn using a port for input.
+ PORT must be seekable.
+ OFFSET is the offset in PORT from which addresses begin.
+ For example, when printing from a bytevector, addresses passed to the
+ bv seek routines must be in the range [0,size). However, the bytevector
+ may represent an instruction at address 0x1234. To handle this case pass
+ 0x1234 for OFFSET.
+ This is based on gdb_print_insn, see it for details. */
+
+static int
+gdbscm_print_insn_from_port (struct gdbarch *gdbarch,
+ SCM port, ULONGEST offset, CORE_ADDR memaddr,
+ struct ui_file *stream, int *branch_delay_insns)
+{
+ struct disassemble_info di;
+ int length;
+ struct gdbscm_disasm_data data;
+
+ di = gdb_disassemble_info (gdbarch, stream);
+ data.gdbarch = gdbarch;
+ data.port = port;
+ data.offset = offset;
+ di.application_data = &data;
+ di.read_memory_func = gdbscm_disasm_read_memory;
+ di.memory_error_func = gdbscm_disasm_memory_error;
+ di.print_address_func = gdbscm_disasm_print_address;
+
+ length = gdbarch_print_insn (gdbarch, memaddr, &di);
+
+ if (branch_delay_insns)
+ {
+ if (di.insn_info_valid)
+ *branch_delay_insns = di.branch_delay_insns;
+ else
+ *branch_delay_insns = 0;
+ }
+
+ return length;
+}
+
+/* (arch-disassemble <gdb:arch> address
+ [#:port port] [#:offset address] [#:size integer] [#:count integer])
+ -> list
+
+ Returns a list of disassembled instructions.
+ If PORT is provided, read bytes from it. Otherwise read target memory.
+ If PORT is #f, read target memory.
+ PORT must be seekable. IWBN to remove this restriction, and a future
+ release may. For now the restriction is in place because it's not clear
+ all disassemblers are strictly sequential.
+ If SIZE is provided, limit the number of bytes read to this amount.
+ If COUNT is provided, limit the number of instructions to this amount.
+
+ Each instruction in the result is an alist:
+ (('address . address) ('asm . disassembly) ('length . length)).
+ We could use a hash table (dictionary) but there aren't that many fields. */
+
+static SCM
+gdbscm_arch_disassemble (SCM self, SCM start_scm, SCM rest)
+{
+ arch_smob *a_smob
+ = arscm_get_arch_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct gdbarch *gdbarch = arscm_get_gdbarch (a_smob);
+ const SCM keywords[] = {
+ port_keyword, offset_keyword, size_keyword, count_keyword, SCM_BOOL_F
+ };
+ int port_arg_pos = -1, offset_arg_pos = -1;
+ int size_arg_pos = -1, count_arg_pos = -1;
+ SCM port = SCM_BOOL_F;
+ ULONGEST offset = 0;
+ unsigned int count = 1;
+ unsigned int size;
+ ULONGEST start_arg;
+ CORE_ADDR start, end;
+ CORE_ADDR pc;
+ unsigned int i;
+ int using_port;
+ SCM result;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "U#OUuu",
+ start_scm, &start_arg, rest,
+ &port_arg_pos, &port,
+ &offset_arg_pos, &offset,
+ &size_arg_pos, &size,
+ &count_arg_pos, &count);
+ /* START is first stored in a ULONGEST because we don't have a format char
+ for CORE_ADDR, and it's not really worth it to have one yet. */
+ start = start_arg;
+
+ if (port_arg_pos > 0)
+ {
+ SCM_ASSERT_TYPE (gdbscm_is_false (port)
+ || gdbscm_is_true (scm_input_port_p (port)),
+ port, port_arg_pos, FUNC_NAME, _("input port"));
+ }
+ using_port = gdbscm_is_true (port);
+
+ if (offset_arg_pos > 0
+ && (port_arg_pos < 0
+ || gdbscm_is_false (port)))
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, offset_arg_pos,
+ gdbscm_scm_from_ulongest (offset),
+ _("offset provided but port is missing"));
+ }
+
+ if (size_arg_pos > 0)
+ {
+ if (size == 0)
+ return SCM_EOL;
+ /* For now be strict about start+size overflowing. If it becomes
+ a nuisance we can relax things later. */
+ if (start + size < start)
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, 0,
+ scm_list_2 (gdbscm_scm_from_ulongest (start),
+ gdbscm_scm_from_ulongest (size)),
+ _("start+size overflows"));
+ }
+ end = start + size - 1;
+ }
+ else
+ end = ~(CORE_ADDR) 0;
+
+ if (count == 0)
+ return SCM_EOL;
+
+ result = SCM_EOL;
+
+ for (pc = start, i = 0; pc <= end && i < count; )
+ {
+ int insn_len = 0;
+ char *as = NULL;
+ struct ui_file *memfile = mem_fileopen ();
+ struct cleanup *cleanups = make_cleanup_ui_file_delete (memfile);
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (using_port)
+ {
+ insn_len = gdbscm_print_insn_from_port (gdbarch, port, offset,
+ pc, memfile, NULL);
+ }
+ else
+ insn_len = gdb_print_insn (gdbarch, pc, memfile, NULL);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ as = ui_file_xstrdup (memfile, NULL);
+
+ result = scm_cons (dascm_make_insn (pc, as, insn_len),
+ result);
+
+ pc += insn_len;
+ i++;
+ do_cleanups (cleanups);
+ xfree (as);
+ }
+
+ return scm_reverse_x (result, SCM_EOL);
+}
+\f
+/* Initialize the Scheme architecture support. */
+
+static const scheme_function disasm_functions[] =
+{
+ { "arch-disassemble", 2, 0, 1, gdbscm_arch_disassemble,
+ "\
+Return list of disassembled instructions in memory.\n\
+\n\
+ Arguments: <gdb:arch> start-address\n\
+ [#:port port] [#:offset address]\n\
+ [#:size <integer>] [#:count <integer>]\n\
+ port: If non-#f, it is an input port to read bytes from.\n\
+ offset: Specifies the address offset of the first byte in the port.\n\
+ This is useful if the input is from something other than memory\n\
+ (e.g., a bytevector) and you want the result to be as if the bytes\n\
+ came from that address. The value to pass for start-address is\n\
+ then also the desired disassembly address, not the offset in, e.g.,\n\
+ the bytevector.\n\
+ size: Limit the number of bytes read to this amount.\n\
+ count: Limit the number of instructions to this amount.\n\
+\n\
+ Returns:\n\
+ Each instruction in the result is an alist:\n\
+ (('address . address) ('asm . disassembly) ('length . length))." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_disasm (void)
+{
+ gdbscm_define_functions (disasm_functions, 1);
+
+ port_keyword = scm_from_latin1_keyword ("port");
+ offset_keyword = scm_from_latin1_keyword ("offset");
+ size_keyword = scm_from_latin1_keyword ("size");
+ count_keyword = scm_from_latin1_keyword ("count");
+
+ address_symbol = scm_from_latin1_symbol ("address");
+ asm_symbol = scm_from_latin1_symbol ("asm");
+ length_symbol = scm_from_latin1_symbol ("length");
+}
--- /dev/null
+/* GDB/Scheme exception support.
+
+ Copyright (C) 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. */
+
+/* Notes:
+
+ IWBN to support SRFI 34/35. At the moment we follow Guile's own
+ exception mechanism.
+
+ The non-static functions in this file have prefix gdbscm_ and
+ not exscm_ on purpose. */
+
+#include "defs.h"
+#include <signal.h>
+#include "gdb_assert.h"
+#include "guile-internal.h"
+
+/* The <gdb:exception> smob.
+ This is used to record and handle Scheme exceptions.
+ One important invariant is that <gdb:exception> smobs are never a valid
+ result of a function, other than to signify an exception occurred. */
+
+typedef struct
+{
+ /* This always appears first. */
+ gdb_smob base;
+
+ /* The key and args parameters to "throw". */
+ SCM key;
+ SCM args;
+} exception_smob;
+
+static const char exception_smob_name[] = "gdb:exception";
+
+/* The tag Guile knows the exception smob by. */
+static scm_t_bits exception_smob_tag;
+
+/* A generic error in struct gdb_exception.
+ I.e., not RETURN_QUIT and not MEMORY_ERROR. */
+static SCM error_symbol;
+
+/* An error occurred accessing inferior memory.
+ This is not a Scheme programming error. */
+static SCM memory_error_symbol;
+
+/* User interrupt, e.g., RETURN_QUIT in struct gdb_exception. */
+static SCM signal_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)).
+ See gdbscm_make_exception_with_stack. */
+static SCM with_stack_error_symbol;
+
+/* The key to use for an invalid object exception. An invalid object is one
+ where the underlying object has been removed from GDB. */
+SCM gdbscm_invalid_object_error_symbol;
+
+/* Values for "guile print-stack" as symbols. */
+static SCM none_symbol;
+static SCM message_symbol;
+static SCM full_symbol;
+
+static const char percent_print_exception_message_name[] =
+ "%print-exception-message";
+
+/* Variable containing %print-exception-message.
+ It is not defined until late in initialization, after our init routine
+ has run. Cope by looking it up lazily. */
+static SCM percent_print_exception_message_var = SCM_BOOL_F;
+
+static const char percent_print_exception_with_stack_name[] =
+ "%print-exception-with-stack";
+
+/* Variable containing %print-exception-with-stack.
+ It is not defined until late in initialization, after our init routine
+ has run. Cope by looking it up lazily. */
+static SCM percent_print_exception_with_stack_var = SCM_BOOL_F;
+
+/* Counter to keep track of the number of times we create a <gdb:exception>
+ object, for performance monitoring purposes. */
+static unsigned long gdbscm_exception_count = 0;
+\f
+/* Administrivia for exception smobs. */
+
+/* The smob "mark" function for <gdb:exception>. */
+
+static SCM
+exscm_mark_exception_smob (SCM self)
+{
+ exception_smob *e_smob = (exception_smob *) SCM_SMOB_DATA (self);
+
+ scm_gc_mark (e_smob->key);
+ scm_gc_mark (e_smob->args);
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&e_smob->base);
+}
+
+/* The smob "print" function for <gdb:exception>. */
+
+static int
+exscm_print_exception_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ exception_smob *e_smob = (exception_smob *) SCM_SMOB_DATA (self);
+
+ gdbscm_printf (port, "#<%s ", exception_smob_name);
+ scm_write (e_smob->key, port);
+ scm_puts (" ", port);
+ scm_write (e_smob->args, port);
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* (make-exception key args) -> <gdb:exception> */
+
+SCM
+gdbscm_make_exception (SCM key, SCM args)
+{
+ exception_smob *e_smob = (exception_smob *)
+ scm_gc_malloc (sizeof (exception_smob), exception_smob_name);
+ SCM smob;
+
+ e_smob->key = key;
+ e_smob->args = args;
+ smob = scm_new_smob (exception_smob_tag, (scm_t_bits) e_smob);
+ gdbscm_init_gsmob (&e_smob->base);
+
+ ++gdbscm_exception_count;
+
+ return smob;
+}
+
+/* Return non-zero if SCM is a <gdb:exception> object. */
+
+int
+gdbscm_is_exception (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (exception_smob_tag, scm);
+}
+
+/* (exception? scm) -> boolean */
+
+static SCM
+gdbscm_exception_p (SCM scm)
+{
+ return scm_from_bool (gdbscm_is_exception (scm));
+}
+
+/* (exception-key <gdb:exception>) -> key */
+
+SCM
+gdbscm_exception_key (SCM self)
+{
+ exception_smob *e_smob;
+
+ SCM_ASSERT_TYPE (gdbscm_is_exception (self), self, SCM_ARG1, FUNC_NAME,
+ "gdb:exception");
+
+ e_smob = (exception_smob *) SCM_SMOB_DATA (self);
+ return e_smob->key;
+}
+
+/* (exception-args <gdb:exception>) -> arg-list */
+
+SCM
+gdbscm_exception_args (SCM self)
+{
+ exception_smob *e_smob;
+
+ SCM_ASSERT_TYPE (gdbscm_is_exception (self), self, SCM_ARG1, FUNC_NAME,
+ "gdb:exception");
+
+ e_smob = (exception_smob *) SCM_SMOB_DATA (self);
+ return e_smob->args;
+}
+\f
+/* Wrap an exception in a <gdb:exception> object that includes STACK.
+ gdbscm_print_exception_with_stack knows how to unwrap it. */
+
+SCM
+gdbscm_make_exception_with_stack (SCM key, SCM args, SCM stack)
+{
+ return gdbscm_make_exception (with_stack_error_symbol,
+ scm_cons (key, scm_cons (stack, args)));
+}
+
+/* Version of scm_error_scm that creates a gdb:exception object that can later
+ be passed to gdbscm_throw.
+ KEY is a symbol denoting the kind of error.
+ SUBR is either #f or a string marking the function in which the error
+ occurred.
+ MESSAGE is either #f or the error message string. It may contain ~a and ~s
+ modifiers, provided by ARGS.
+ ARGS is a list of args to MESSAGE.
+ DATA is an arbitrary object, its value depends on KEY. The value to pass
+ here is a bit underspecified by Guile. */
+
+SCM
+gdbscm_make_error_scm (SCM key, SCM subr, SCM message, SCM args, SCM data)
+{
+ return gdbscm_make_exception (key, scm_list_4 (subr, message, args, data));
+}
+
+/* Version of scm_error that creates a gdb:exception object that can later
+ be passed to gdbscm_throw.
+ See gdbscm_make_error_scm for a description of the arguments. */
+
+SCM
+gdbscm_make_error (SCM key, const char *subr, const char *message,
+ SCM args, SCM data)
+{
+ return gdbscm_make_error_scm
+ (key,
+ subr == NULL ? SCM_BOOL_F : scm_from_latin1_string (subr),
+ message == NULL ? SCM_BOOL_F : scm_from_latin1_string (message),
+ args, data);
+}
+
+/* Version of SCM_ASSERT_TYPE/scm_wrong_type_arg_msg that creates a
+ gdb:exception object that can later be passed to gdbscm_throw. */
+
+SCM
+gdbscm_make_type_error (const char *subr, int arg_pos, SCM bad_value,
+ const char *expected_type)
+{
+ char *msg;
+ SCM result;
+
+ if (arg_pos > 0)
+ {
+ if (expected_type != NULL)
+ {
+ msg = xstrprintf (_("Wrong type argument in position %d"
+ " (expecting %s): ~S"),
+ arg_pos, expected_type);
+ }
+ else
+ {
+ msg = xstrprintf (_("Wrong type argument in position %d: ~S"),
+ arg_pos);
+ }
+ }
+ else
+ {
+ if (expected_type != NULL)
+ {
+ msg = xstrprintf (_("Wrong type argument (expecting %s): ~S"),
+ expected_type);
+ }
+ else
+ msg = xstrprintf (_("Wrong type argument: ~S"));
+ }
+
+ result = gdbscm_make_error (scm_arg_type_key, subr, msg,
+ scm_list_1 (bad_value), scm_list_1 (bad_value));
+ xfree (msg);
+ return result;
+}
+
+/* A variant of gdbscm_make_type_error for non-type argument errors.
+ ERROR_PREFIX and ERROR are combined to build the error message.
+ Care needs to be taken so that the i18n composed form is still
+ reasonable, but no one is going to translate these anyway so we don't
+ worry too much.
+ ERROR_PREFIX may be NULL, ERROR may not be NULL. */
+
+static SCM
+gdbscm_make_arg_error (SCM key, const char *subr, int arg_pos, SCM bad_value,
+ const char *error_prefix, const char *error)
+{
+ char *msg;
+ SCM result;
+
+ if (error_prefix != NULL)
+ {
+ if (arg_pos > 0)
+ {
+ msg = xstrprintf (_("%s %s in position %d: ~S"),
+ error_prefix, error, arg_pos);
+ }
+ else
+ msg = xstrprintf (_("%s %s: ~S"), error_prefix, error);
+ }
+ else
+ {
+ if (arg_pos > 0)
+ msg = xstrprintf (_("%s in position %d: ~S"), error, arg_pos);
+ else
+ msg = xstrprintf (_("%s: ~S"), error);
+ }
+
+ result = gdbscm_make_error (key, subr, msg,
+ scm_list_1 (bad_value), scm_list_1 (bad_value));
+ xfree (msg);
+ return result;
+}
+
+/* Make an invalid-object error <gdb:exception> object.
+ OBJECT is the name of the kind of object that is invalid. */
+
+SCM
+gdbscm_make_invalid_object_error (const char *subr, int arg_pos, SCM bad_value,
+ const char *object)
+{
+ return gdbscm_make_arg_error (gdbscm_invalid_object_error_symbol,
+ subr, arg_pos, bad_value,
+ _("Invalid object:"), object);
+}
+
+/* Throw an invalid-object error.
+ OBJECT is the name of the kind of object that is invalid. */
+
+SCM
+gdbscm_invalid_object_error (const char *subr, int arg_pos, SCM bad_value,
+ const char *object)
+{
+ SCM exception
+ = gdbscm_make_invalid_object_error (subr, arg_pos, bad_value, object);
+
+ gdbscm_throw (exception);
+}
+
+/* Make an out-of-range error <gdb:exception> object. */
+
+SCM
+gdbscm_make_out_of_range_error (const char *subr, int arg_pos, SCM bad_value,
+ const char *error)
+{
+ return gdbscm_make_arg_error (scm_out_of_range_key,
+ subr, arg_pos, bad_value,
+ _("Out of range:"), error);
+}
+
+/* Throw an out-of-range error.
+ This is the standard Guile out-of-range exception. */
+
+SCM
+gdbscm_out_of_range_error (const char *subr, int arg_pos, SCM bad_value,
+ const char *error)
+{
+ SCM exception
+ = gdbscm_make_out_of_range_error (subr, arg_pos, bad_value, error);
+
+ gdbscm_throw (exception);
+}
+
+/* Make a misc-error <gdb:exception> object. */
+
+SCM
+gdbscm_make_misc_error (const char *subr, int arg_pos, SCM bad_value,
+ const char *error)
+{
+ return gdbscm_make_arg_error (scm_misc_error_key,
+ subr, arg_pos, bad_value, NULL, error);
+}
+
+/* Return a <gdb:exception> object for gdb:memory-error. */
+
+SCM
+gdbscm_make_memory_error (const char *subr, const char *msg, SCM args)
+{
+ return gdbscm_make_error (memory_error_symbol, subr, msg, args,
+ SCM_EOL);
+}
+
+/* Throw a gdb:memory-error exception. */
+
+SCM
+gdbscm_memory_error (const char *subr, const char *msg, SCM args)
+{
+ SCM exception = gdbscm_make_memory_error (subr, msg, args);
+
+ gdbscm_throw (exception);
+}
+
+/* Return non-zero if KEY is gdb:memory-error.
+ Note: This is an excp_matcher_func function. */
+
+int
+gdbscm_memory_error_p (SCM key)
+{
+ return scm_is_eq (key, memory_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. */
+
+void
+gdbscm_throw (SCM exception)
+{
+ scm_throw (gdbscm_exception_key (exception),
+ gdbscm_exception_args (exception));
+ gdb_assert_not_reached ("scm_throw returned");
+}
+
+/* Convert a GDB exception to a <gdb:exception> object. */
+
+SCM
+gdbscm_scm_from_gdb_exception (struct gdb_exception exception)
+{
+ SCM key;
+
+ if (exception.reason == RETURN_QUIT)
+ {
+ /* Handle this specially to be consistent with top-repl.scm. */
+ return gdbscm_make_error (signal_symbol, NULL, _("User interrupt"),
+ SCM_EOL, scm_list_1 (scm_from_int (SIGINT)));
+ }
+
+ if (exception.error == MEMORY_ERROR)
+ key = memory_error_symbol;
+ else
+ key = error_symbol;
+
+ return gdbscm_make_error (key, NULL, "~A",
+ scm_list_1 (gdbscm_scm_from_c_string
+ (exception.message)),
+ SCM_BOOL_F);
+}
+
+/* Convert a GDB exception to the appropriate Scheme exception and throw it.
+ This function does not return. */
+
+void
+gdbscm_throw_gdb_exception (struct gdb_exception exception)
+{
+ gdbscm_throw (gdbscm_scm_from_gdb_exception (exception));
+}
+
+/* Print the error message portion of an exception.
+ If PORT is #f, use the standard error port.
+ KEY cannot be gdb:with-stack.
+
+ Basically this function is just a wrapper around calling
+ %print-exception-message. */
+
+static void
+gdbscm_print_exception_message (SCM port, SCM frame, SCM key, SCM args)
+{
+ SCM printer, status;
+
+ if (gdbscm_is_false (port))
+ port = scm_current_error_port ();
+
+ gdb_assert (!scm_is_eq (key, with_stack_error_symbol));
+
+ /* This does not use scm_print_exception because we tweak the output a bit.
+ Compare Guile's print-exception with our %print-exception-message for
+ details. */
+ if (gdbscm_is_false (percent_print_exception_message_var))
+ {
+ percent_print_exception_message_var
+ = scm_c_private_variable (gdbscm_init_module_name,
+ percent_print_exception_message_name);
+ /* If we can't find %print-exception-message, there's a problem on the
+ Scheme side. Don't kill GDB, just flag an error and leave it at
+ that. */
+ if (gdbscm_is_false (percent_print_exception_message_var))
+ {
+ gdbscm_printf (port, _("Error in Scheme exception printing,"
+ " can't find %s.\n"),
+ percent_print_exception_message_name);
+ return;
+ }
+ }
+ printer = scm_variable_ref (percent_print_exception_message_var);
+
+ status = gdbscm_safe_call_4 (printer, port, frame, key, args, NULL);
+
+ /* If that failed still tell the user something.
+ But don't use the exception printing machinery! */
+ if (gdbscm_is_exception (status))
+ {
+ gdbscm_printf (port, _("Error in Scheme exception printing:\n"));
+ scm_display (status, port);
+ scm_newline (port);
+ }
+}
+
+/* Print the description of exception KEY, ARGS to PORT, according to the
+ setting of "set guile print-stack".
+ If PORT is #f, use the standard error port.
+ If STACK is #f, never print the stack, regardless of whether printing it
+ is enabled. If STACK is #t, then print it if it is contained in ARGS
+ (i.e., KEY is gdb:with-stack). Otherwise STACK is the result of calling
+ scm_make_stack (which will be ignored in favor of the stack in ARGS if
+ KEY is gdb:with-stack).
+ KEY, ARGS are the standard arguments to scm_throw, et.al.
+
+ Basically this function is just a wrapper around calling
+ %print-exception-with-args. */
+
+void
+gdbscm_print_exception_with_stack (SCM port, SCM stack, SCM key, SCM args)
+{
+ SCM printer, status;
+
+ if (gdbscm_is_false (port))
+ port = scm_current_error_port ();
+
+ if (gdbscm_is_false (percent_print_exception_with_stack_var))
+ {
+ percent_print_exception_with_stack_var
+ = scm_c_private_variable (gdbscm_init_module_name,
+ percent_print_exception_with_stack_name);
+ /* If we can't find %print-exception-with-args, there's a problem on the
+ Scheme side. Don't kill GDB, just flag an error and leave it at
+ that. */
+ if (gdbscm_is_false (percent_print_exception_with_stack_var))
+ {
+ gdbscm_printf (port, _("Error in Scheme exception printing,"
+ " can't find %s.\n"),
+ percent_print_exception_with_stack_name);
+ return;
+ }
+ }
+ printer = scm_variable_ref (percent_print_exception_with_stack_var);
+
+ status = gdbscm_safe_call_4 (printer, port, stack, key, args, NULL);
+
+ /* If that failed still tell the user something.
+ But don't use the exception printing machinery! */
+ if (gdbscm_is_exception (status))
+ {
+ gdbscm_printf (port, _("Error in Scheme exception printing:\n"));
+ scm_display (status, port);
+ scm_newline (port);
+ }
+}
+
+/* Print EXCEPTION, a <gdb:exception> object, to PORT.
+ If PORT is #f, use the standard error port. */
+
+void
+gdbscm_print_gdb_exception (SCM port, SCM exception)
+{
+ gdb_assert (gdbscm_is_exception (exception));
+
+ gdbscm_print_exception_with_stack (port, SCM_BOOL_T,
+ gdbscm_exception_key (exception),
+ gdbscm_exception_args (exception));
+}
+
+/* Return a string description of <gdb:exception> EXCEPTION.
+ If EXCEPTION is a gdb:with-stack exception, unwrap it, a backtrace
+ is never returned as part of the result.
+
+ Space for the result is malloc'd, the caller must free. */
+
+char *
+gdbscm_exception_message_to_string (SCM exception)
+{
+ SCM port = scm_open_output_string ();
+ SCM key, args;
+ char *result;
+
+ gdb_assert (gdbscm_is_exception (exception));
+
+ key = gdbscm_exception_key (exception);
+ args = gdbscm_exception_args (exception);
+
+ if (scm_is_eq (key, with_stack_error_symbol)
+ /* Don't crash on a badly generated gdb:with-stack exception. */
+ && scm_is_pair (args)
+ && scm_is_pair (scm_cdr (args)))
+ {
+ key = scm_car (args);
+ args = scm_cddr (args);
+ }
+
+ gdbscm_print_exception_message (port, SCM_BOOL_F, key, args);
+ result = gdbscm_scm_to_c_string (scm_get_output_string (port));
+ scm_close_port (port);
+
+ return result;
+}
+
+/* Return the value of the "guile print-stack" option as one of:
+ 'none, 'message, 'full. */
+
+static SCM
+gdbscm_percent_exception_print_style (void)
+{
+ if (gdbscm_print_excp == gdbscm_print_excp_none)
+ return none_symbol;
+ if (gdbscm_print_excp == gdbscm_print_excp_message)
+ return message_symbol;
+ if (gdbscm_print_excp == gdbscm_print_excp_full)
+ return full_symbol;
+ gdb_assert_not_reached ("bad value for \"guile print-stack\"");
+}
+
+/* Return the current <gdb:exception> counter.
+ This is for debugging purposes. */
+
+static SCM
+gdbscm_percent_exception_count (void)
+{
+ return scm_from_ulong (gdbscm_exception_count);
+}
+\f
+/* Initialize the Scheme exception support. */
+
+static const scheme_function exception_functions[] =
+{
+ { "make-exception", 2, 0, 0, gdbscm_make_exception,
+ "\
+Create a <gdb:exception> object.\n\
+\n\
+ Arguments: key args\n\
+ These are the standard key,args arguments of \"throw\"." },
+
+ { "exception?", 1, 0, 0, gdbscm_exception_p,
+ "\
+Return #t if the object is a <gdb:exception> object." },
+
+ { "exception-key", 1, 0, 0, gdbscm_exception_key,
+ "\
+Return the exception's key." },
+
+ { "exception-args", 1, 0, 0, gdbscm_exception_args,
+ "\
+Return the exception's arg list." },
+
+ END_FUNCTIONS
+};
+
+static const scheme_function private_exception_functions[] =
+{
+ { "%exception-print-style", 0, 0, 0, gdbscm_percent_exception_print_style,
+ "\
+Return the value of the \"guile print-stack\" option." },
+
+ { "%exception-count", 0, 0, 0, gdbscm_percent_exception_count,
+ "\
+Return a count of the number of <gdb:exception> objects created.\n\
+This is for debugging purposes." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_exceptions (void)
+{
+ exception_smob_tag = gdbscm_make_smob_type (exception_smob_name,
+ sizeof (exception_smob));
+ scm_set_smob_mark (exception_smob_tag, exscm_mark_exception_smob);
+ scm_set_smob_print (exception_smob_tag, exscm_print_exception_smob);
+
+ gdbscm_define_functions (exception_functions, 1);
+ gdbscm_define_functions (private_exception_functions, 0);
+
+ error_symbol = scm_from_latin1_symbol ("gdb:error");
+
+ memory_error_symbol = scm_from_latin1_symbol ("gdb:memory-error");
+
+ gdbscm_invalid_object_error_symbol
+ = scm_from_latin1_symbol ("gdb:invalid-object-error");
+
+ with_stack_error_symbol = scm_from_latin1_symbol ("gdb:with-stack");
+
+ /* The text of this symbol is taken from Guile's top-repl.scm. */
+ signal_symbol = scm_from_latin1_symbol ("signal");
+
+ none_symbol = scm_from_latin1_symbol ("none");
+ message_symbol = scm_from_latin1_symbol ("message");
+ full_symbol = scm_from_latin1_symbol ("full");
+}
--- /dev/null
+/* Scheme interface to stack frames.
+
+ 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 "block.h"
+#include "frame.h"
+#include "exceptions.h"
+#include "inferior.h"
+#include "objfiles.h"
+#include "symfile.h"
+#include "symtab.h"
+#include "stack.h"
+#include "value.h"
+#include "guile-internal.h"
+
+/* The <gdb:frame> smob.
+ The typedef for this struct is in guile-internal.h. */
+
+struct _frame_smob
+{
+ /* This always appears first. */
+ eqable_gdb_smob base;
+
+ struct frame_id frame_id;
+ struct gdbarch *gdbarch;
+
+ /* Frames are tracked by inferior.
+ We need some place to put the eq?-able hash table, and this feels as
+ good a place as any. Frames in one inferior shouldn't be considered
+ equal to frames in a different inferior. The frame becomes invalid if
+ this becomes NULL (the inferior has been deleted from gdb).
+ It's easier to relax restrictions than impose them after the fact.
+ N.B. It is an outstanding question whether a frame survives reruns of
+ the inferior. Intuitively the answer is "No", but currently a frame
+ also survives, e.g., multiple invocations of the same function from
+ the same point. Even different threads can have the same frame, e.g.,
+ if a thread dies and a new thread gets the same stack. */
+ struct inferior *inferior;
+
+ /* Marks that the FRAME_ID member actually holds the ID of the frame next
+ to this, and not this frame's ID itself. This is a hack to permit Scheme
+ frame objects which represent invalid frames (i.e., the last frame_info
+ in a corrupt stack). The problem arises from the fact that this code
+ relies on FRAME_ID to uniquely identify a frame, which is not always true
+ for the last "frame" in a corrupt stack (it can have a null ID, or the
+ same ID as the previous frame). Whenever get_prev_frame returns NULL, we
+ record the frame_id of the next frame and set FRAME_ID_IS_NEXT to 1. */
+ int frame_id_is_next;
+};
+
+static const char frame_smob_name[] = "gdb:frame";
+
+/* The tag Guile knows the frame smob by. */
+static scm_t_bits frame_smob_tag;
+
+/* Keywords used in argument passing. */
+static SCM block_keyword;
+
+static const struct inferior_data *frscm_inferior_data_key;
+\f
+/* Administrivia for frame smobs. */
+
+/* Helper function to hash a frame_smob. */
+
+static hashval_t
+frscm_hash_frame_smob (const void *p)
+{
+ const frame_smob *f_smob = p;
+ const struct frame_id *fid = &f_smob->frame_id;
+ hashval_t hash = htab_hash_pointer (f_smob->inferior);
+
+ if (fid->stack_status == FID_STACK_VALID)
+ hash = iterative_hash (&fid->stack_addr, sizeof (fid->stack_addr), hash);
+ if (fid->code_addr_p)
+ hash = iterative_hash (&fid->code_addr, sizeof (fid->code_addr), hash);
+ if (fid->special_addr_p)
+ hash = iterative_hash (&fid->special_addr, sizeof (fid->special_addr),
+ hash);
+
+ return hash;
+}
+
+/* Helper function to compute equality of frame_smobs. */
+
+static int
+frscm_eq_frame_smob (const void *ap, const void *bp)
+{
+ const frame_smob *a = ap;
+ const frame_smob *b = bp;
+
+ return (frame_id_eq (a->frame_id, b->frame_id)
+ && a->inferior == b->inferior
+ && a->inferior != NULL);
+}
+
+/* Return the frame -> SCM mapping table.
+ It is created if necessary. */
+
+static htab_t
+frscm_inferior_frame_map (struct inferior *inferior)
+{
+ htab_t htab = inferior_data (inferior, frscm_inferior_data_key);
+
+ if (htab == NULL)
+ {
+ htab = gdbscm_create_eqable_gsmob_ptr_map (frscm_hash_frame_smob,
+ frscm_eq_frame_smob);
+ set_inferior_data (inferior, frscm_inferior_data_key, htab);
+ }
+
+ return htab;
+}
+
+/* The smob "mark" function for <gdb:frame>. */
+
+static SCM
+frscm_mark_frame_smob (SCM self)
+{
+ frame_smob *f_smob = (frame_smob *) SCM_SMOB_DATA (self);
+
+ /* Do this last. */
+ return gdbscm_mark_eqable_gsmob (&f_smob->base);
+}
+
+/* The smob "free" function for <gdb:frame>. */
+
+static size_t
+frscm_free_frame_smob (SCM self)
+{
+ frame_smob *f_smob = (frame_smob *) SCM_SMOB_DATA (self);
+
+ if (f_smob->inferior != NULL)
+ {
+ htab_t htab = frscm_inferior_frame_map (f_smob->inferior);
+
+ gdbscm_clear_eqable_gsmob_ptr_slot (htab, &f_smob->base);
+ }
+
+ /* Not necessary, done to catch bugs. */
+ f_smob->inferior = NULL;
+
+ return 0;
+}
+
+/* The smob "print" function for <gdb:frame>. */
+
+static int
+frscm_print_frame_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ frame_smob *f_smob = (frame_smob *) SCM_SMOB_DATA (self);
+ struct ui_file *strfile;
+ char *s;
+
+ gdbscm_printf (port, "#<%s ", frame_smob_name);
+
+ strfile = mem_fileopen ();
+ fprint_frame_id (strfile, f_smob->frame_id);
+ s = ui_file_xstrdup (strfile, NULL);
+ gdbscm_printf (port, "%s", s);
+ ui_file_delete (strfile);
+ xfree (s);
+
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to create a <gdb:frame> object. */
+
+static SCM
+frscm_make_frame_smob (void)
+{
+ frame_smob *f_smob = (frame_smob *)
+ scm_gc_malloc (sizeof (frame_smob), frame_smob_name);
+ SCM f_scm;
+
+ f_smob->frame_id = null_frame_id;
+ f_smob->gdbarch = NULL;
+ f_smob->inferior = NULL;
+ f_smob->frame_id_is_next = 0;
+ f_scm = scm_new_smob (frame_smob_tag, (scm_t_bits) f_smob);
+ gdbscm_init_eqable_gsmob (&f_smob->base);
+
+ return f_scm;
+}
+
+/* Return non-zero if SCM is a <gdb:frame> object. */
+
+int
+frscm_is_frame (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (frame_smob_tag, scm);
+}
+
+/* (frame? object) -> boolean */
+
+static SCM
+gdbscm_frame_p (SCM scm)
+{
+ return scm_from_bool (frscm_is_frame (scm));
+}
+
+/* Create a new <gdb:frame> object that encapsulates FRAME.
+ Returns a <gdb:exception> object if there is an error. */
+
+static SCM
+frscm_scm_from_frame (struct frame_info *frame, struct inferior *inferior)
+{
+ frame_smob *f_smob, f_smob_for_lookup;
+ SCM f_scm;
+ htab_t htab;
+ eqable_gdb_smob **slot;
+ volatile struct gdb_exception except;
+ struct frame_id frame_id = null_frame_id;
+ struct gdbarch *gdbarch = NULL;
+ int frame_id_is_next = 0;
+
+ /* If we've already created a gsmob for this frame, return it.
+ This makes frames eq?-able. */
+ htab = frscm_inferior_frame_map (inferior);
+ f_smob_for_lookup.frame_id = get_frame_id (frame);
+ f_smob_for_lookup.inferior = inferior;
+ slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &f_smob_for_lookup.base);
+ if (*slot != NULL)
+ return (*slot)->containing_scm;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ /* Try to get the previous frame, to determine if this is the last frame
+ in a corrupt stack. If so, we need to store the frame_id of the next
+ frame and not of this one (which is possibly invalid). */
+ if (get_prev_frame (frame) == NULL
+ && get_frame_unwind_stop_reason (frame) != UNWIND_NO_REASON
+ && get_next_frame (frame) != NULL)
+ {
+ frame_id = get_frame_id (get_next_frame (frame));
+ frame_id_is_next = 1;
+ }
+ else
+ {
+ frame_id = get_frame_id (frame);
+ frame_id_is_next = 0;
+ }
+ gdbarch = get_frame_arch (frame);
+ }
+ if (except.reason < 0)
+ return gdbscm_scm_from_gdb_exception (except);
+
+ f_scm = frscm_make_frame_smob ();
+ f_smob = (frame_smob *) SCM_SMOB_DATA (f_scm);
+ f_smob->frame_id = frame_id;
+ f_smob->gdbarch = gdbarch;
+ f_smob->inferior = inferior;
+ f_smob->frame_id_is_next = frame_id_is_next;
+
+ gdbscm_fill_eqable_gsmob_ptr_slot (slot, &f_smob->base, f_scm);
+
+ return f_scm;
+}
+
+/* Create a new <gdb:frame> object that encapsulates FRAME.
+ A Scheme exception is thrown if there is an error. */
+
+static SCM
+frscm_scm_from_frame_unsafe (struct frame_info *frame,
+ struct inferior *inferior)
+{
+ SCM f_scm = frscm_scm_from_frame (frame, inferior);
+
+ if (gdbscm_is_exception (f_scm))
+ gdbscm_throw (f_scm);
+
+ return f_scm;
+}
+
+/* Returns the <gdb:frame> object in SELF.
+ Throws an exception if SELF is not a <gdb:frame> object. */
+
+static SCM
+frscm_get_frame_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (frscm_is_frame (self), self, arg_pos, func_name,
+ frame_smob_name);
+
+ return self;
+}
+
+/* There is no gdbscm_scm_to_frame function because translating
+ a frame SCM object to a struct frame_info * can throw a GDB error.
+ Thus code working with frames has to handle both Scheme errors (e.g., the
+ object is not a frame) and GDB errors (e.g., the frame lookup failed).
+
+ To help keep things clear we split gdbscm_scm_to_frame into two:
+
+ gdbscm_get_frame_smob_arg_unsafe
+ - throws a Scheme error if object is not a frame,
+ or if the inferior is gone or is no longer current
+
+ gdbscm_frame_smob_to_frame
+ - may throw a gdb error if the conversion fails
+ - it's not clear when it will and won't throw a GDB error,
+ but for robustness' sake we assume that whenever we call out to GDB
+ a GDB error may get thrown (and thus the call must be wrapped in a
+ TRY_CATCH) */
+
+/* Returns the frame_smob for the object wrapped by FRAME_SCM.
+ A Scheme error is thrown if FRAME_SCM is not a frame. */
+
+frame_smob *
+frscm_get_frame_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM f_scm = frscm_get_frame_arg_unsafe (self, arg_pos, func_name);
+ frame_smob *f_smob = (frame_smob *) SCM_SMOB_DATA (f_scm);
+
+ if (f_smob->inferior == NULL)
+ {
+ gdbscm_invalid_object_error (func_name, arg_pos, self,
+ _("inferior"));
+ }
+ if (f_smob->inferior != current_inferior ())
+ scm_misc_error (func_name, _("inferior has changed"), SCM_EOL);
+
+ return f_smob;
+}
+
+/* Returns the frame_info object wrapped by F_SMOB.
+ If the frame doesn't exist anymore (the frame id doesn't
+ correspond to any frame in the inferior), returns NULL.
+ This function calls GDB routines, so don't assume a GDB error will
+ not be thrown. */
+
+struct frame_info *
+frscm_frame_smob_to_frame (frame_smob *f_smob)
+{
+ struct frame_info *frame;
+
+ frame = frame_find_by_id (f_smob->frame_id);
+ if (frame == NULL)
+ return NULL;
+
+ if (f_smob->frame_id_is_next)
+ frame = get_prev_frame (frame);
+
+ return frame;
+}
+
+/* Helper function for frscm_del_inferior_frames to mark the frame
+ as invalid. */
+
+static int
+frscm_mark_frame_invalid (void **slot, void *info)
+{
+ frame_smob *f_smob = (frame_smob *) *slot;
+
+ f_smob->inferior = NULL;
+ return 1;
+}
+
+/* This function is called when an inferior is about to be freed.
+ Invalidate the frame as further actions on the frame could result
+ in bad data. All access to the frame should be gated by
+ frscm_get_frame_smob_arg_unsafe which will raise an exception on
+ invalid frames. */
+
+static void
+frscm_del_inferior_frames (struct inferior *inferior, void *datum)
+{
+ htab_t htab = datum;
+
+ if (htab != NULL)
+ {
+ htab_traverse_noresize (htab, frscm_mark_frame_invalid, NULL);
+ htab_delete (htab);
+ }
+}
+\f
+/* Frame methods. */
+
+/* (frame-valid? <gdb:frame>) -> bool
+ Returns #t if the frame corresponding to the frame_id of this
+ object still exists in the inferior. */
+
+static SCM
+gdbscm_frame_valid_p (SCM self)
+{
+ frame_smob *f_smob;
+ struct frame_info *frame = NULL;
+ volatile struct gdb_exception except;
+
+ f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = frscm_frame_smob_to_frame (f_smob);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return scm_from_bool (frame != NULL);
+}
+
+/* (frame-name <gdb:frame>) -> string
+ Returns the name of the function corresponding to this frame,
+ or #f if there is no function. */
+
+static SCM
+gdbscm_frame_name (SCM self)
+{
+ frame_smob *f_smob;
+ char *name = NULL;
+ enum language lang = language_minimal;
+ struct frame_info *frame = NULL;
+ SCM result;
+ volatile struct gdb_exception except;
+
+ f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = frscm_frame_smob_to_frame (f_smob);
+ if (frame != NULL)
+ find_frame_funname (frame, &name, &lang, NULL);
+ }
+ if (except.reason < 0)
+ xfree (name);
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (frame == NULL)
+ {
+ gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
+ _("<gdb:frame>"));
+ }
+
+ if (name != NULL)
+ {
+ result = gdbscm_scm_from_c_string (name);
+ xfree (name);
+ }
+ else
+ result = SCM_BOOL_F;
+
+ return result;
+}
+
+/* (frame-type <gdb:frame>) -> integer
+ Returns the frame type, namely one of the gdb:*_FRAME constants. */
+
+static SCM
+gdbscm_frame_type (SCM self)
+{
+ frame_smob *f_smob;
+ enum frame_type type = NORMAL_FRAME;
+ struct frame_info *frame = NULL;
+ volatile struct gdb_exception except;
+
+ f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = frscm_frame_smob_to_frame (f_smob);
+ if (frame != NULL)
+ type = get_frame_type (frame);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (frame == NULL)
+ {
+ gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
+ _("<gdb:frame>"));
+ }
+
+ return scm_from_int (type);
+}
+
+/* (frame-arch <gdb:frame>) -> <gdb:architecture>
+ Returns the frame's architecture as a gdb:architecture object. */
+
+static SCM
+gdbscm_frame_arch (SCM self)
+{
+ frame_smob *f_smob;
+ struct frame_info *frame = NULL;
+ volatile struct gdb_exception except;
+
+ f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = frscm_frame_smob_to_frame (f_smob);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (frame == NULL)
+ {
+ gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
+ _("<gdb:frame>"));
+ }
+
+ return arscm_scm_from_arch (f_smob->gdbarch);
+}
+
+/* (frame-unwind-stop-reason <gdb:frame>) -> integer
+ Returns one of the gdb:FRAME_UNWIND_* constants. */
+
+static SCM
+gdbscm_frame_unwind_stop_reason (SCM self)
+{
+ frame_smob *f_smob;
+ struct frame_info *frame = NULL;
+ volatile struct gdb_exception except;
+ enum unwind_stop_reason stop_reason;
+
+ f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = frscm_frame_smob_to_frame (f_smob);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (frame == NULL)
+ {
+ gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
+ _("<gdb:frame>"));
+ }
+
+ stop_reason = get_frame_unwind_stop_reason (frame);
+
+ return scm_from_int (stop_reason);
+}
+
+/* (frame-pc <gdb:frame>) -> integer
+ Returns the frame's resume address. */
+
+static SCM
+gdbscm_frame_pc (SCM self)
+{
+ frame_smob *f_smob;
+ CORE_ADDR pc = 0;
+ struct frame_info *frame = NULL;
+ volatile struct gdb_exception except;
+
+ f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = frscm_frame_smob_to_frame (f_smob);
+ if (frame != NULL)
+ pc = get_frame_pc (frame);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (frame == NULL)
+ {
+ gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
+ _("<gdb:frame>"));
+ }
+
+ return gdbscm_scm_from_ulongest (pc);
+}
+
+/* (frame-block <gdb:frame>) -> <gdb:block>
+ Returns the frame's code block, or #f if one cannot be found. */
+
+static SCM
+gdbscm_frame_block (SCM self)
+{
+ frame_smob *f_smob;
+ struct block *block = NULL, *fn_block;
+ struct frame_info *frame = NULL;
+ volatile struct gdb_exception except;
+
+ f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = frscm_frame_smob_to_frame (f_smob);
+ if (frame != NULL)
+ block = get_frame_block (frame, NULL);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (frame == NULL)
+ {
+ gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
+ _("<gdb:frame>"));
+ }
+
+ for (fn_block = block;
+ fn_block != NULL && BLOCK_FUNCTION (fn_block) == NULL;
+ fn_block = BLOCK_SUPERBLOCK (fn_block))
+ continue;
+
+ if (block == NULL || fn_block == NULL || BLOCK_FUNCTION (fn_block) == NULL)
+ {
+ scm_misc_error (FUNC_NAME, _("cannot find block for frame"),
+ scm_list_1 (self));
+ }
+
+ if (block != NULL)
+ {
+ struct symtab *st;
+ SCM block_scm;
+
+ st = SYMBOL_SYMTAB (BLOCK_FUNCTION (fn_block));
+ return bkscm_scm_from_block (block, st->objfile);
+ }
+
+ return SCM_BOOL_F;
+}
+
+/* (frame-function <gdb:frame>) -> <gdb:symbol>
+ Returns the symbol for the function corresponding to this frame,
+ or #f if there isn't one. */
+
+static SCM
+gdbscm_frame_function (SCM self)
+{
+ frame_smob *f_smob;
+ struct symbol *sym = NULL;
+ struct frame_info *frame = NULL;
+ volatile struct gdb_exception except;
+
+ f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = frscm_frame_smob_to_frame (f_smob);
+ if (frame != NULL)
+ sym = find_pc_function (get_frame_address_in_block (frame));
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (frame == NULL)
+ {
+ gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
+ _("<gdb:frame>"));
+ }
+
+ if (sym != NULL)
+ return syscm_scm_from_symbol (sym);
+
+ return SCM_BOOL_F;
+}
+
+/* (frame-older <gdb:frame>) -> <gdb:frame>
+ Returns the frame immediately older (outer) to this frame,
+ or #f if there isn't one. */
+
+static SCM
+gdbscm_frame_older (SCM self)
+{
+ frame_smob *f_smob;
+ struct frame_info *prev = NULL;
+ struct frame_info *frame = NULL;
+ volatile struct gdb_exception except;
+
+ f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = frscm_frame_smob_to_frame (f_smob);
+ if (frame != NULL)
+ prev = get_prev_frame (frame);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (frame == NULL)
+ {
+ gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
+ _("<gdb:frame>"));
+ }
+
+ if (prev != NULL)
+ return frscm_scm_from_frame_unsafe (prev, f_smob->inferior);
+
+ return SCM_BOOL_F;
+}
+
+/* (frame-newer <gdb:frame>) -> <gdb:frame>
+ Returns the frame immediately newer (inner) to this frame,
+ or #f if there isn't one. */
+
+static SCM
+gdbscm_frame_newer (SCM self)
+{
+ frame_smob *f_smob;
+ struct frame_info *next = NULL;
+ struct frame_info *frame = NULL;
+ volatile struct gdb_exception except;
+
+ f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = frscm_frame_smob_to_frame (f_smob);
+ if (frame != NULL)
+ next = get_next_frame (frame);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (frame == NULL)
+ {
+ gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
+ _("<gdb:frame>"));
+ }
+
+ if (next != NULL)
+ return frscm_scm_from_frame_unsafe (next, f_smob->inferior);
+
+ return SCM_BOOL_F;
+}
+
+/* (frame-sal <gdb:frame>) -> <gdb:sal>
+ Returns the frame's symtab and line. */
+
+static SCM
+gdbscm_frame_sal (SCM self)
+{
+ frame_smob *f_smob;
+ struct symtab_and_line sal;
+ struct frame_info *frame = NULL;
+ volatile struct gdb_exception except;
+
+ f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = frscm_frame_smob_to_frame (f_smob);
+ if (frame != NULL)
+ find_frame_sal (frame, &sal);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (frame == NULL)
+ {
+ gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
+ _("<gdb:frame>"));
+ }
+
+ return stscm_scm_from_sal (sal);
+}
+
+/* (frame-read-var <gdb:frame> <gdb:symbol>) -> <gdb:value>
+ (frame-read-var <gdb:frame> string [#:block <gdb:block>]) -> <gdb:value>
+ If the optional block argument is provided start the search from that block,
+ otherwise search from the frame's current block (determined by examining
+ the resume address of the frame). The variable argument must be a string
+ or an instance of a <gdb:symbol>. The block argument must be an instance of
+ <gdb:block>. */
+
+static SCM
+gdbscm_frame_read_var (SCM self, SCM symbol_scm, SCM rest)
+{
+ SCM keywords[] = { block_keyword, SCM_BOOL_F };
+ int rc;
+ frame_smob *f_smob;
+ int block_arg_pos = -1;
+ SCM block_scm = SCM_UNDEFINED;
+ struct frame_info *frame = NULL;
+ struct symbol *var = NULL;
+ struct value *value = NULL;
+ volatile struct gdb_exception except;
+
+ f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = frscm_frame_smob_to_frame (f_smob);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (frame == NULL)
+ {
+ gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
+ _("<gdb:frame>"));
+ }
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG3, keywords, "#O",
+ rest, &block_arg_pos, &block_scm);
+
+ if (syscm_is_symbol (symbol_scm))
+ {
+ var = syscm_get_valid_symbol_arg_unsafe (symbol_scm, SCM_ARG2,
+ FUNC_NAME);
+ SCM_ASSERT (SCM_UNBNDP (block_scm), block_scm, SCM_ARG3, FUNC_NAME);
+ }
+ else if (scm_is_string (symbol_scm))
+ {
+ char *var_name;
+ const struct block *block = NULL;
+ struct cleanup *cleanup;
+ volatile struct gdb_exception except;
+
+ if (! SCM_UNBNDP (block_scm))
+ {
+ SCM except_scm;
+
+ gdb_assert (block_arg_pos > 0);
+ block = bkscm_scm_to_block (block_scm, block_arg_pos, FUNC_NAME,
+ &except_scm);
+ if (block == NULL)
+ gdbscm_throw (except_scm);
+ }
+
+ var_name = gdbscm_scm_to_c_string (symbol_scm);
+ cleanup = make_cleanup (xfree, var_name);
+ /* N.B. Between here and the call to do_cleanups, don't do anything
+ to cause a Scheme exception without performing the cleanup. */
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (block == NULL)
+ block = get_frame_block (frame, NULL);
+ var = lookup_symbol (var_name, block, VAR_DOMAIN, NULL);
+ }
+ if (except.reason < 0)
+ do_cleanups (cleanup);
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (var == NULL)
+ {
+ do_cleanups (cleanup);
+ gdbscm_out_of_range_error (FUNC_NAME, 0, symbol_scm,
+ _("variable not found"));
+ }
+
+ do_cleanups (cleanup);
+ }
+ else
+ {
+ /* Use SCM_ASSERT_TYPE for more consistent error messages. */
+ SCM_ASSERT_TYPE (0, symbol_scm, SCM_ARG1, FUNC_NAME,
+ _("gdb:symbol or string"));
+ }
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ value = read_var_value (var, frame);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return vlscm_scm_from_value (value);
+}
+
+/* (frame-select <gdb:frame>) -> unspecified
+ Select this frame. */
+
+static SCM
+gdbscm_frame_select (SCM self)
+{
+ frame_smob *f_smob;
+ struct frame_info *frame = NULL;
+ volatile struct gdb_exception except;
+
+ f_smob = frscm_get_frame_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = frscm_frame_smob_to_frame (f_smob);
+ if (frame != NULL)
+ select_frame (frame);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (frame == NULL)
+ {
+ gdbscm_invalid_object_error (FUNC_NAME, SCM_ARG1, self,
+ _("<gdb:frame>"));
+ }
+
+ return SCM_UNSPECIFIED;
+}
+
+/* (newest-frame) -> <gdb:frame>
+ Returns the newest frame. */
+
+static SCM
+gdbscm_newest_frame (void)
+{
+ struct frame_info *frame = NULL;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = get_current_frame ();
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return frscm_scm_from_frame_unsafe (frame, current_inferior ());
+}
+
+/* (selected-frame) -> <gdb:frame>
+ Returns the selected frame. */
+
+static SCM
+gdbscm_selected_frame (void)
+{
+ struct frame_info *frame = NULL;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ frame = get_selected_frame (_("No frame is currently selected"));
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return frscm_scm_from_frame_unsafe (frame, current_inferior ());
+}
+
+/* (unwind-stop-reason-string integer) -> string
+ Return a string explaining the unwind stop reason. */
+
+static SCM
+gdbscm_unwind_stop_reason_string (SCM reason_scm)
+{
+ int reason;
+ const char *str;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i",
+ reason_scm, &reason);
+
+ if (reason < UNWIND_FIRST || reason > UNWIND_LAST)
+ scm_out_of_range (FUNC_NAME, reason_scm);
+
+ str = frame_stop_reason_string (reason);
+ return gdbscm_scm_from_c_string (str);
+}
+\f
+/* Initialize the Scheme frame support. */
+
+static const scheme_integer_constant frame_integer_constants[] =
+{
+#define ENTRY(X) { #X, X }
+
+ ENTRY (NORMAL_FRAME),
+ ENTRY (DUMMY_FRAME),
+ ENTRY (INLINE_FRAME),
+ ENTRY (TAILCALL_FRAME),
+ ENTRY (SIGTRAMP_FRAME),
+ ENTRY (ARCH_FRAME),
+ ENTRY (SENTINEL_FRAME),
+
+#undef ENTRY
+
+#define SET(name, description) \
+ { "FRAME_" #name, name },
+#include "unwind_stop_reasons.def"
+#undef SET
+
+ END_INTEGER_CONSTANTS
+};
+
+static const scheme_function frame_functions[] =
+{
+ { "frame?", 1, 0, 0, gdbscm_frame_p,
+ "\
+Return #t if the object is a <gdb:frame> object." },
+
+ { "frame-valid?", 1, 0, 0, gdbscm_frame_valid_p,
+ "\
+Return #t if the object is a valid <gdb:frame> object.\n\
+Frames become invalid when the inferior returns to its caller." },
+
+ { "frame-name", 1, 0, 0, gdbscm_frame_name,
+ "\
+Return the name of the function corresponding to this frame,\n\
+or #f if there is no function." },
+
+ { "frame-arch", 1, 0, 0, gdbscm_frame_arch,
+ "\
+Return the frame's architecture as a <gdb:arch> object." },
+
+ { "frame-type", 1, 0, 0, gdbscm_frame_type,
+ "\
+Return the frame type, namely one of the gdb:*_FRAME constants." },
+
+ { "frame-unwind-stop-reason", 1, 0, 0, gdbscm_frame_unwind_stop_reason,
+ "\
+Return one of the gdb:FRAME_UNWIND_* constants explaining why\n\
+it's not possible to find frames older than this." },
+
+ { "frame-pc", 1, 0, 0, gdbscm_frame_pc,
+ "\
+Return the frame's resume address." },
+
+ { "frame-block", 1, 0, 0, gdbscm_frame_block,
+ "\
+Return the frame's code block, or #f if one cannot be found." },
+
+ { "frame-function", 1, 0, 0, gdbscm_frame_function,
+ "\
+Return the <gdb:symbol> for the function corresponding to this frame,\n\
+or #f if there isn't one." },
+
+ { "frame-older", 1, 0, 0, gdbscm_frame_older,
+ "\
+Return the frame immediately older (outer) to this frame,\n\
+or #f if there isn't one." },
+
+ { "frame-newer", 1, 0, 0, gdbscm_frame_newer,
+ "\
+Return the frame immediately newer (inner) to this frame,\n\
+or #f if there isn't one." },
+
+ { "frame-sal", 1, 0, 0, gdbscm_frame_sal,
+ "\
+Return the frame's symtab-and-line <gdb:sal> object." },
+
+ { "frame-read-var", 2, 0, 1, gdbscm_frame_read_var,
+ "\
+Return the value of the symbol in the frame.\n\
+\n\
+ Arguments: <gdb:frame> <gdb:symbol>\n\
+ Or: <gdb:frame> string [#:block <gdb:block>]" },
+
+ { "frame-select", 1, 0, 0, gdbscm_frame_select,
+ "\
+Select this frame." },
+
+ { "newest-frame", 0, 0, 0, gdbscm_newest_frame,
+ "\
+Return the newest frame." },
+
+ { "selected-frame", 0, 0, 0, gdbscm_selected_frame,
+ "\
+Return the selected frame." },
+
+ { "unwind-stop-reason-string", 1, 0, 0, gdbscm_unwind_stop_reason_string,
+ "\
+Return a string explaining the unwind stop reason.\n\
+\n\
+ Arguments: integer (the result of frame-unwind-stop-reason)" },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_frames (void)
+{
+ frame_smob_tag
+ = gdbscm_make_smob_type (frame_smob_name, sizeof (frame_smob));
+ scm_set_smob_mark (frame_smob_tag, frscm_mark_frame_smob);
+ scm_set_smob_free (frame_smob_tag, frscm_free_frame_smob);
+ scm_set_smob_print (frame_smob_tag, frscm_print_frame_smob);
+
+ gdbscm_define_integer_constants (frame_integer_constants, 1);
+ gdbscm_define_functions (frame_functions, 1);
+
+ block_keyword = scm_from_latin1_keyword ("block");
+
+ /* Register an inferior "free" callback so we can properly
+ invalidate frames when an inferior file is about to be deleted. */
+ frscm_inferior_data_key
+ = register_inferior_data_with_cleanup (NULL, frscm_del_inferior_frames);
+}
--- /dev/null
+/* GDB/Scheme smobs (gsmob is pronounced "jee smob")
+
+ Copyright (C) 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. */
+
+/* Smobs are Guile's "small object".
+ They are used to export C structs to Scheme.
+
+ Note: There's only room in the encoding space for 256, and while we won't
+ come close to that, mixed with other libraries maybe someday we could.
+ We don't worry about it now, except to be aware of the issue.
+ We could allocate just a few smobs and use the unused smob flags field to
+ specify the gdb smob kind, that is left for another day if it ever is
+ needed.
+
+ We want the objects we export to Scheme to be extensible by the user.
+ A gsmob (gdb smob) adds a simple API on top of smobs to support this.
+ This allows GDB objects to be easily extendable in a useful manner.
+ To that end, all smobs in gdb have gdb_smob as the first member.
+
+ On top of gsmobs there are "chained gsmobs". They are used to assist with
+ life-time tracking of GDB objects vs Scheme objects. Gsmobs can "subclass"
+ chained_gdb_smob, which contains a doubly-linked list to assist with
+ life-time tracking.
+
+ On top of gsmobs there are also "eqable gsmobs". Gsmobs can "subclass"
+ eqable_gdb_smob instead of gdb_smob, and is used to make gsmobs eq?-able.
+ This is done by recording all gsmobs in a hash table and before creating a
+ gsmob first seeing if it's already in the table. Eqable gsmobs can also be
+ used where lifetime-tracking is required.
+
+ Gsmobs (and chained/eqable gsmobs) add an extra field that is used to
+ record extra data: "properties". It is a table of key/value pairs
+ that can be set with set-gsmob-property!, gsmob-property. */
+
+#include "defs.h"
+#include "hashtab.h"
+#include "gdb_assert.h"
+#include "objfiles.h"
+#include "guile-internal.h"
+
+/* We need to call this. Undo our hack to prevent others from calling it. */
+#undef scm_make_smob_type
+
+static htab_t registered_gsmobs;
+
+/* Gsmob properties are initialize stored as an alist to minimize space
+ usage: GDB can be used to debug some really big programs, and property
+ lists generally have very few elements. Once the list grows to this
+ many elements then we switch to a hash table.
+ The smallest Guile hashtable in 2.0 uses a vector of 31 elements.
+ The value we use here is large enough to hold several expected uses,
+ without being so large that we might as well just use a hashtable. */
+#define SMOB_PROP_HTAB_THRESHOLD 7
+
+/* Hash function for registered_gsmobs hash table. */
+
+static hashval_t
+hash_scm_t_bits (const void *item)
+{
+ uintptr_t v = (uintptr_t) item;
+
+ return v;
+}
+
+/* Equality function for registered_gsmobs hash table. */
+
+static int
+eq_scm_t_bits (const void *item_lhs, const void *item_rhs)
+{
+ return item_lhs == item_rhs;
+}
+
+/* Record GSMOB_CODE as being a gdb smob.
+ GSMOB_CODE is the result of scm_make_smob_type. */
+
+static void
+register_gsmob (scm_t_bits gsmob_code)
+{
+ void **slot;
+
+ slot = htab_find_slot (registered_gsmobs, (void *) gsmob_code, INSERT);
+ gdb_assert (*slot == NULL);
+ *slot = (void *) gsmob_code;
+}
+
+/* Return non-zero if SCM is any registered gdb smob object. */
+
+static int
+gdbscm_is_gsmob (SCM scm)
+{
+ void **slot;
+
+ if (SCM_IMP (scm))
+ return 0;
+ slot = htab_find_slot (registered_gsmobs, (void *) SCM_TYP16 (scm),
+ NO_INSERT);
+ return slot != NULL;
+}
+
+/* Call this to register a smob, instead of scm_make_smob_type. */
+
+scm_t_bits
+gdbscm_make_smob_type (const char *name, size_t size)
+{
+ scm_t_bits result = scm_make_smob_type (name, size);
+
+ register_gsmob (result);
+ return result;
+}
+
+/* Initialize a gsmob. */
+
+void
+gdbscm_init_gsmob (gdb_smob *base)
+{
+ base->properties = SCM_EOL;
+}
+
+/* Initialize a chained_gdb_smob.
+ This is the same as gdbscm_init_gsmob except that it also sets prev,next
+ to NULL. */
+
+void
+gdbscm_init_chained_gsmob (chained_gdb_smob *base)
+{
+ gdbscm_init_gsmob ((gdb_smob *) base);
+ base->prev = NULL;
+ base->next = NULL;
+}
+
+/* Initialize an eqable_gdb_smob.
+ This is the same as gdbscm_init_gsmob except that it also sets
+ containing_scm to #f. */
+
+void
+gdbscm_init_eqable_gsmob (eqable_gdb_smob *base)
+{
+ gdbscm_init_gsmob ((gdb_smob *) base);
+ base->containing_scm = SCM_BOOL_F;
+}
+
+/* Call this from each smob's "mark" routine.
+ In general, this should be called as:
+ return gdbscm_mark_gsmob (base); */
+
+SCM
+gdbscm_mark_gsmob (gdb_smob *base)
+{
+ /* Return the last one to mark as an optimization.
+ The marking infrastructure will mark it for us. */
+ return base->properties;
+}
+
+/* Call this from each smob's "mark" routine.
+ In general, this should be called as:
+ return gdbscm_mark_chained_gsmob (base); */
+
+SCM
+gdbscm_mark_chained_gsmob (chained_gdb_smob *base)
+{
+ /* Return the last one to mark as an optimization.
+ The marking infrastructure will mark it for us. */
+ return base->properties;
+}
+
+/* Call this from each smob's "mark" routine.
+ In general, this should be called as:
+ return gdbscm_mark_eqable_gsmob (base); */
+
+SCM
+gdbscm_mark_eqable_gsmob (eqable_gdb_smob *base)
+{
+ /* There's no need to mark containing_scm.
+ Any references to it either come from Scheme in which case it will be
+ marked through them, or there's a reference to the smob from gdb in
+ which case the smob is GC-protected. */
+
+ /* Return the last one to mark as an optimization.
+ The marking infrastructure will mark it for us. */
+ return base->properties;
+}
+\f
+/* gsmob accessors */
+
+/* Return the gsmob in SELF.
+ Throws an exception if SELF is not a gsmob. */
+
+static SCM
+gsscm_get_gsmob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (gdbscm_is_gsmob (self), self, arg_pos, func_name,
+ _("any gdb smob"));
+
+ return self;
+}
+
+/* (gsmob-kind gsmob) -> symbol
+
+ Note: While one might want to name this gsmob-class-name, it is named
+ "-kind" because smobs aren't real GOOPS classes. */
+
+static SCM
+gdbscm_gsmob_kind (SCM self)
+{
+ SCM smob, result;
+ scm_t_bits smobnum;
+ const char *name;
+ char *kind;
+
+ smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ smobnum = SCM_SMOBNUM (smob);
+ name = SCM_SMOBNAME (smobnum);
+ kind = xstrprintf ("<%s>", name);
+ result = scm_from_latin1_symbol (kind);
+ xfree (kind);
+
+ return result;
+}
+
+/* (gsmob-property gsmob property) -> object
+ If property isn't present then #f is returned. */
+
+static SCM
+gdbscm_gsmob_property (SCM self, SCM property)
+{
+ SCM smob;
+ gdb_smob *base;
+
+ smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ base = (gdb_smob *) SCM_SMOB_DATA (self);
+
+ /* Have we switched to a hash table? */
+ if (gdbscm_is_true (scm_hash_table_p (base->properties)))
+ return scm_hashq_ref (base->properties, property, SCM_BOOL_F);
+
+ return scm_assq_ref (base->properties, property);
+}
+
+/* (set-gsmob-property! gsmob property new-value) -> unspecified */
+
+static SCM
+gdbscm_set_gsmob_property_x (SCM self, SCM property, SCM new_value)
+{
+ SCM smob, alist;
+ gdb_smob *base;
+
+ smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ base = (gdb_smob *) SCM_SMOB_DATA (self);
+
+ /* Have we switched to a hash table? */
+ if (gdbscm_is_true (scm_hash_table_p (base->properties)))
+ {
+ scm_hashq_set_x (base->properties, property, new_value);
+ return SCM_UNSPECIFIED;
+ }
+
+ alist = scm_assq_set_x (base->properties, property, new_value);
+
+ /* Did we grow the list? */
+ if (!scm_is_eq (alist, base->properties))
+ {
+ /* If we grew the list beyond a threshold in size,
+ switch to a hash table. */
+ if (scm_ilength (alist) >= SMOB_PROP_HTAB_THRESHOLD)
+ {
+ SCM elm, htab;
+
+ htab = scm_c_make_hash_table (SMOB_PROP_HTAB_THRESHOLD);
+ for (elm = alist; elm != SCM_EOL; elm = scm_cdr (elm))
+ scm_hashq_set_x (htab, scm_caar (elm), scm_cdar (elm));
+ base->properties = htab;
+ return SCM_UNSPECIFIED;
+ }
+ }
+
+ base->properties = alist;
+ return SCM_UNSPECIFIED;
+}
+
+/* (gsmob-has-property? gsmob property) -> boolean */
+
+static SCM
+gdbscm_gsmob_has_property_p (SCM self, SCM property)
+{
+ SCM smob, handle;
+ gdb_smob *base;
+
+ smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ base = (gdb_smob *) SCM_SMOB_DATA (self);
+
+ if (gdbscm_is_true (scm_hash_table_p (base->properties)))
+ handle = scm_hashq_get_handle (base->properties, property);
+ else
+ handle = scm_assq (property, base->properties);
+
+ return scm_from_bool (gdbscm_is_true (handle));
+}
+
+/* Helper function for gdbscm_gsmob_properties. */
+
+static SCM
+add_property_name (void *closure, SCM handle)
+{
+ SCM *resultp = closure;
+
+ *resultp = scm_cons (scm_car (handle), *resultp);
+ return SCM_UNSPECIFIED;
+}
+
+/* (gsmob-properties gsmob) -> list
+ The list is unsorted. */
+
+static SCM
+gdbscm_gsmob_properties (SCM self)
+{
+ SCM smob, handle, result;
+ gdb_smob *base;
+
+ smob = gsscm_get_gsmob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ base = (gdb_smob *) SCM_SMOB_DATA (self);
+
+ result = SCM_EOL;
+ if (gdbscm_is_true (scm_hash_table_p (base->properties)))
+ {
+ scm_internal_hash_for_each_handle (add_property_name, &result,
+ base->properties);
+ }
+ else
+ {
+ SCM elm;
+
+ for (elm = base->properties; elm != SCM_EOL; elm = scm_cdr (elm))
+ result = scm_cons (scm_caar (elm), result);
+ }
+
+ return result;
+}
+\f
+/* When underlying gdb data structures are deleted, we need to update any
+ smobs with references to them. There are several smobs that reference
+ objfile-based data, so we provide helpers to manage this. */
+
+/* Add G_SMOB to the reference chain for OBJFILE specified by DATA_KEY.
+ OBJFILE may be NULL, in which case just set prev,next to NULL. */
+
+void
+gdbscm_add_objfile_ref (struct objfile *objfile,
+ const struct objfile_data *data_key,
+ chained_gdb_smob *g_smob)
+{
+ g_smob->prev = NULL;
+ if (objfile != NULL)
+ {
+ g_smob->next = objfile_data (objfile, data_key);
+ if (g_smob->next)
+ g_smob->next->prev = g_smob;
+ set_objfile_data (objfile, data_key, g_smob);
+ }
+ else
+ g_smob->next = NULL;
+}
+
+/* Remove G_SMOB from the reference chain for OBJFILE specified
+ by DATA_KEY. OBJFILE may be NULL. */
+
+void
+gdbscm_remove_objfile_ref (struct objfile *objfile,
+ const struct objfile_data *data_key,
+ chained_gdb_smob *g_smob)
+{
+ if (g_smob->prev)
+ g_smob->prev->next = g_smob->next;
+ else if (objfile != NULL)
+ set_objfile_data (objfile, data_key, g_smob->next);
+ if (g_smob->next)
+ g_smob->next->prev = g_smob->prev;
+}
+
+/* Create a hash table for mapping a pointer to a gdb data structure to the
+ gsmob that wraps it. */
+
+htab_t
+gdbscm_create_eqable_gsmob_ptr_map (htab_hash hash_fn, htab_eq eq_fn)
+{
+ htab_t htab = htab_create_alloc (7, hash_fn, eq_fn,
+ NULL, xcalloc, xfree);
+
+ return htab;
+}
+
+/* Return a pointer to the htab entry for the eq?-able gsmob BASE.
+ If the entry is found, *SLOT is non-NULL.
+ Otherwise *slot is NULL. */
+
+eqable_gdb_smob **
+gdbscm_find_eqable_gsmob_ptr_slot (htab_t htab, eqable_gdb_smob *base)
+{
+ void **slot = htab_find_slot (htab, base, INSERT);
+
+ return (eqable_gdb_smob **) slot;
+}
+
+/* Record CONTAINING_SCM as the object containing BASE, and record it in
+ SLOT. SLOT must be the result of calling gdbscm_find_eqable_gsmob_ptr_slot
+ on BASE (or equivalent for lookup). */
+
+void
+gdbscm_fill_eqable_gsmob_ptr_slot (eqable_gdb_smob **slot,
+ eqable_gdb_smob *base,
+ SCM containing_scm)
+{
+ base->containing_scm = containing_scm;
+ *slot = base;
+}
+
+/* Remove BASE from HTAB.
+ BASE is a pointer to a gsmob that wraps a pointer to a GDB datum.
+ This is used, for example, when an object is freed.
+
+ It is an error to call this if PTR is not in HTAB (only because it allows
+ for some consistency checking). */
+
+void
+gdbscm_clear_eqable_gsmob_ptr_slot (htab_t htab, eqable_gdb_smob *base)
+{
+ void **slot = htab_find_slot (htab, base, NO_INSERT);
+
+ gdb_assert (slot != NULL);
+ htab_clear_slot (htab, slot);
+}
+\f
+/* Initialize the Scheme gsmobs code. */
+
+static const scheme_function gsmob_functions[] =
+{
+ { "gsmob-kind", 1, 0, 0, gdbscm_gsmob_kind,
+ "\
+Return the kind of the smob, e.g., <gdb:breakpoint>, as a symbol." },
+
+ { "gsmob-property", 2, 0, 0, gdbscm_gsmob_property,
+ "\
+Return the specified property of the gsmob." },
+
+ { "set-gsmob-property!", 3, 0, 0, gdbscm_set_gsmob_property_x,
+ "\
+Set the specified property of the gsmob." },
+
+ { "gsmob-has-property?", 2, 0, 0, gdbscm_gsmob_has_property_p,
+ "\
+Return #t if the specified property is present." },
+
+ { "gsmob-properties", 1, 0, 0, gdbscm_gsmob_properties,
+ "\
+Return an unsorted list of names of properties." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_smobs (void)
+{
+ registered_gsmobs = htab_create_alloc (10,
+ hash_scm_t_bits, eq_scm_t_bits,
+ NULL, xcalloc, xfree);
+
+ gdbscm_define_functions (gsmob_functions, 1);
+}
--- /dev/null
+/* Simple iterators for GDB/Scheme.
+
+ Copyright (C) 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. */
+
+/* These are *simple* iterators, used to implement iterating over a collection
+ of objects. They are implemented as a smob containing three objects:
+
+ 1) the object being iterated over,
+ 2) an object to record the progress of the iteration,
+ 3) a procedure of one argument (the iterator object) that returns the next
+ object in the iteration or a pre-determined end marker.
+
+ Simple example:
+
+ (define-public (make-list-iterator l end-marker)
+ "Return a <gdb:iterator> object for a list."
+ (let ((next! (lambda (iter)
+ (let ((l (iterator-progress iter)))
+ (if (eq? l '())
+ end-marker
+ (begin
+ (set-iterator-progress! iter (cdr l))
+ (car l)))))))
+ (make-iterator l l next!)))
+
+ (define l '(1 2))
+ (define i (make-list-iterator l #:eoi))
+ (iterator-next! i) -> 1
+ (iterator-next! i) -> 2
+ (iterator-next! i) -> #:eoi
+
+ There is SRFI 41, Streams. We might support that too eventually (not with
+ this interface of course). */
+
+#include "defs.h"
+#include "guile-internal.h"
+
+/* A smob for iterating over something.
+ Typically this is used when computing a list of everything is
+ too expensive.
+ The typedef for this struct is in guile-internal.h. */
+
+struct _iterator_smob
+{
+ /* This always appears first. */
+ gdb_smob base;
+
+ /* The object being iterated over. */
+ SCM object;
+
+ /* An arbitrary object describing the progress of the iteration.
+ This is used by next_x to track progress. */
+ SCM progress;
+
+ /* A procedure of one argument, the iterator.
+ It returns the next object in the iteration.
+ How to signal "end of iteration" is up to next_x. */
+ SCM next_x;
+};
+
+static const char iterator_smob_name[] = "gdb:iterator";
+
+/* The tag Guile knows the iterator smob by. */
+static scm_t_bits iterator_smob_tag;
+
+/* A unique-enough marker to denote "end of iteration". */
+static SCM end_of_iteration;
+
+const char *
+itscm_iterator_smob_name (void)
+{
+ return iterator_smob_name;
+}
+
+SCM
+itscm_iterator_smob_object (iterator_smob *i_smob)
+{
+ return i_smob->object;
+}
+
+SCM
+itscm_iterator_smob_progress (iterator_smob *i_smob)
+{
+ return i_smob->progress;
+}
+
+void
+itscm_set_iterator_smob_progress_x (iterator_smob *i_smob, SCM progress)
+{
+ i_smob->progress = progress;
+}
+\f
+/* Administrivia for iterator smobs. */
+
+/* The smob "mark" function for <gdb:iterator>. */
+
+static SCM
+itscm_mark_iterator_smob (SCM self)
+{
+ iterator_smob *i_smob = (iterator_smob *) SCM_SMOB_DATA (self);
+
+ scm_gc_mark (i_smob->object);
+ scm_gc_mark (i_smob->progress);
+ scm_gc_mark (i_smob->next_x);
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&i_smob->base);
+}
+
+/* The smob "print" function for <gdb:iterator>. */
+
+static int
+itscm_print_iterator_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ iterator_smob *i_smob = (iterator_smob *) SCM_SMOB_DATA (self);
+
+ gdbscm_printf (port, "#<%s ", iterator_smob_name);
+ scm_write (i_smob->object, port);
+ scm_puts (" ", port);
+ scm_write (i_smob->progress, port);
+ scm_puts (" ", port);
+ scm_write (i_smob->next_x, port);
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to make a <gdb:iterator> object.
+ Caller must verify correctness of arguments.
+ No exceptions are thrown. */
+
+static SCM
+itscm_make_iterator_smob (SCM object, SCM progress, SCM next)
+{
+ iterator_smob *i_smob = (iterator_smob *)
+ scm_gc_malloc (sizeof (iterator_smob), iterator_smob_name);
+ SCM i_scm;
+
+ i_smob->object = object;
+ i_smob->progress = progress;
+ i_smob->next_x = next;
+ i_scm = scm_new_smob (iterator_smob_tag, (scm_t_bits) i_smob);
+ gdbscm_init_gsmob (&i_smob->base);
+
+ return i_scm;
+}
+
+/* (make-iterator object object procedure) -> <gdb:iterator> */
+
+SCM
+gdbscm_make_iterator (SCM object, SCM progress, SCM next)
+{
+ SCM i_scm;
+
+ SCM_ASSERT_TYPE (gdbscm_is_procedure (next), next, SCM_ARG3, FUNC_NAME,
+ _("procedure"));
+
+ i_scm = itscm_make_iterator_smob (object, progress, next);
+
+ return i_scm;
+}
+
+/* Return non-zero if SCM is a <gdb:iterator> object. */
+
+int
+itscm_is_iterator (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (iterator_smob_tag, scm);
+}
+
+/* (iterator? object) -> boolean */
+
+static SCM
+gdbscm_iterator_p (SCM scm)
+{
+ return scm_from_bool (itscm_is_iterator (scm));
+}
+
+/* (end-of-iteration) -> an "end-of-iteration" marker
+ We rely on this not being used as a data result of an iterator. */
+
+SCM
+gdbscm_end_of_iteration (void)
+{
+ return end_of_iteration;
+}
+
+/* Return non-zero if OBJ is the end-of-iteration marker. */
+
+int
+itscm_is_end_of_iteration (SCM obj)
+{
+ return scm_is_eq (obj, end_of_iteration);
+}
+
+/* (end-of-iteration? obj) -> boolean */
+
+static SCM
+gdbscm_end_of_iteration_p (SCM obj)
+{
+ return scm_from_bool (itscm_is_end_of_iteration (obj));
+}
+
+/* Call the next! method on ITER, which must be a <gdb:iterator> object.
+ Returns a <gdb:exception> object if an exception is thrown.
+ OK_EXCPS is passed to gdbscm_safe_call_1. */
+
+SCM
+itscm_safe_call_next_x (SCM iter, excp_matcher_func *ok_excps)
+{
+ iterator_smob *i_smob;
+
+ gdb_assert (itscm_is_iterator (iter));
+
+ i_smob = (iterator_smob *) SCM_SMOB_DATA (iter);
+ return gdbscm_safe_call_1 (i_smob->next_x, iter, ok_excps);
+}
+\f
+/* Iterator methods. */
+
+/* Returns the <gdb:iterator> smob in SELF.
+ Throws an exception if SELF is not an iterator smob. */
+
+SCM
+itscm_get_iterator_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (itscm_is_iterator (self), self, arg_pos, func_name,
+ iterator_smob_name);
+
+ return self;
+}
+
+/* (iterator-object <gdb:iterator>) -> object */
+
+static SCM
+gdbscm_iterator_object (SCM self)
+{
+ SCM i_scm;
+ iterator_smob *i_smob;
+
+ i_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ i_smob = (iterator_smob *) SCM_SMOB_DATA (i_scm);
+
+ return i_smob->object;
+}
+
+/* (iterator-progress <gdb:iterator>) -> object */
+
+static SCM
+gdbscm_iterator_progress (SCM self)
+{
+ SCM i_scm;
+ iterator_smob *i_smob;
+
+ i_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ i_smob = (iterator_smob *) SCM_SMOB_DATA (i_scm);
+
+ return i_smob->progress;
+}
+
+/* (set-iterator-progress! <gdb:iterator> object) -> unspecified */
+
+static SCM
+gdbscm_set_iterator_progress_x (SCM self, SCM value)
+{
+ SCM i_scm;
+ iterator_smob *i_smob;
+
+ i_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ i_smob = (iterator_smob *) SCM_SMOB_DATA (i_scm);
+
+ i_smob->progress = value;
+ return SCM_UNSPECIFIED;
+}
+
+/* (iterator-next! <gdb:iterator>) -> object
+ The result is the next value in the iteration or some "end" marker.
+ It is up to each iterator's next! function to specify what its end
+ marker is. */
+
+static SCM
+gdbscm_iterator_next_x (SCM self)
+{
+ SCM i_scm;
+ iterator_smob *i_smob;
+
+ i_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ i_smob = (iterator_smob *) SCM_SMOB_DATA (i_scm);
+ /* We leave type-checking of the procedure to gdbscm_safe_call_1. */
+
+ return gdbscm_safe_call_1 (i_smob->next_x, self, NULL);
+}
+\f
+/* Initialize the Scheme iterator code. */
+
+static const scheme_function iterator_functions[] =
+{
+ { "make-iterator", 3, 0, 0, gdbscm_make_iterator,
+ "\
+Create a <gdb:iterator> object.\n\
+\n\
+ Arguments: object progress next!\n\
+ object: The object to iterate over.\n\
+ progress: An object to use to track progress of the iteration.\n\
+ next!: A procedure of one argument, the iterator.\n\
+ Returns the next element in the iteration or an implementation-chosen\n\
+ value to signify iteration is complete.\n\
+ By convention end-of-iteration should be marked with (end-of-iteration)\n\
+ from module (gdb iterator)." },
+
+ { "iterator?", 1, 0, 0, gdbscm_iterator_p,
+ "\
+Return #t if the object is a <gdb:iterator> object." },
+
+ { "iterator-object", 1, 0, 0, gdbscm_iterator_object,
+ "\
+Return the object being iterated over." },
+
+ { "iterator-progress", 1, 0, 0, gdbscm_iterator_progress,
+ "\
+Return the progress object of the iterator." },
+
+ { "set-iterator-progress!", 2, 0, 0, gdbscm_set_iterator_progress_x,
+ "\
+Set the progress object of the iterator." },
+
+ { "iterator-next!", 1, 0, 0, gdbscm_iterator_next_x,
+ "\
+Invoke the next! procedure of the iterator and return its result." },
+
+ { "end-of-iteration", 0, 0, 0, gdbscm_end_of_iteration,
+ "\
+Return the end-of-iteration marker." },
+
+ { "end-of-iteration?", 1, 0, 0, gdbscm_end_of_iteration_p,
+ "\
+Return #t if the object is the end-of-iteration marker." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_iterators (void)
+{
+ iterator_smob_tag = gdbscm_make_smob_type (iterator_smob_name,
+ sizeof (iterator_smob));
+ scm_set_smob_mark (iterator_smob_tag, itscm_mark_iterator_smob);
+ scm_set_smob_print (iterator_smob_tag, itscm_print_iterator_smob);
+
+ gdbscm_define_functions (iterator_functions, 1);
+
+ /* We can make this more unique if it's necessary,
+ but this is good enough for now. */
+ end_of_iteration = scm_from_latin1_keyword ("end-of-iteration");
+}
--- /dev/null
+/* Scheme interface to lazy strings.
+
+ Copyright (C) 2010-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 "charset.h"
+#include "value.h"
+#include "exceptions.h"
+#include "valprint.h"
+#include "language.h"
+#include "gdb_assert.h"
+#include "guile-internal.h"
+
+/* The <gdb:lazy-string> smob. */
+
+typedef struct
+{
+ /* This always appears first. */
+ gdb_smob base;
+
+ /* Holds the address of the lazy string. */
+ CORE_ADDR address;
+
+ /* Holds the encoding that will be applied to the string when the string
+ is printed by GDB. If the encoding is set to NULL then GDB will select
+ the most appropriate encoding when the sting is printed.
+ Space for this is malloc'd and will be freed when the object is
+ freed. */
+ char *encoding;
+
+ /* Holds the length of the string in characters. If the length is -1,
+ then the string will be fetched and encoded up to the first null of
+ appropriate width. */
+ int length;
+
+ /* This attribute holds the type that is represented by the lazy
+ string's type. */
+ struct type *type;
+} lazy_string_smob;
+
+static const char lazy_string_smob_name[] = "gdb:lazy-string";
+
+/* The tag Guile knows the lazy string smob by. */
+static scm_t_bits lazy_string_smob_tag;
+\f
+/* Administrivia for lazy string smobs. */
+
+/* The smob "mark" function for <gdb:lazy-string>. */
+
+static SCM
+lsscm_mark_lazy_string_smob (SCM self)
+{
+ lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (self);
+
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&ls_smob->base);
+}
+
+/* The smob "free" function for <gdb:lazy-string>. */
+
+static size_t
+lsscm_free_lazy_string_smob (SCM self)
+{
+ lazy_string_smob *v_smob = (lazy_string_smob *) SCM_SMOB_DATA (self);
+
+ xfree (v_smob->encoding);
+
+ return 0;
+}
+
+/* The smob "print" function for <gdb:lazy-string>. */
+
+static int
+lsscm_print_lazy_string_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (self);
+
+ gdbscm_printf (port, "#<%s", lazy_string_smob_name);
+ gdbscm_printf (port, " @%s", hex_string (ls_smob->address));
+ if (ls_smob->length >= 0)
+ gdbscm_printf (port, " length %d", ls_smob->length);
+ if (ls_smob->encoding != NULL)
+ gdbscm_printf (port, " encoding %s", ls_smob->encoding);
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to create a <gdb:lazy-string> object.
+ The caller must verify !(address == 0 && length != 0). */
+
+static SCM
+lsscm_make_lazy_string_smob (CORE_ADDR address, int length,
+ const char *encoding, struct type *type)
+{
+ lazy_string_smob *ls_smob = (lazy_string_smob *)
+ scm_gc_malloc (sizeof (lazy_string_smob), lazy_string_smob_name);
+ SCM ls_scm;
+
+ /* Caller must verify this. */
+ gdb_assert (!(address == 0 && length != 0));
+ gdb_assert (type != NULL);
+
+ ls_smob->address = address;
+ /* Coerce all values < 0 to -1. */
+ ls_smob->length = length < 0 ? -1 : length;
+ if (encoding == NULL || strcmp (encoding, "") == 0)
+ ls_smob->encoding = NULL;
+ else
+ ls_smob->encoding = xstrdup (encoding);
+ ls_smob->type = type;
+
+ ls_scm = scm_new_smob (lazy_string_smob_tag, (scm_t_bits) ls_smob);
+ gdbscm_init_gsmob (&ls_smob->base);
+
+ return ls_scm;
+}
+
+/* Return non-zero if SCM is a <gdb:lazy-string> object. */
+
+int
+lsscm_is_lazy_string (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (lazy_string_smob_tag, scm);
+}
+
+/* (lazy-string? object) -> boolean */
+
+static SCM
+gdbscm_lazy_string_p (SCM scm)
+{
+ return scm_from_bool (lsscm_is_lazy_string (scm));
+}
+
+/* Main entry point to create a <gdb:lazy-string> object.
+ If there's an error a <gdb:exception> object is returned. */
+
+SCM
+lsscm_make_lazy_string (CORE_ADDR address, int length,
+ const char *encoding, struct type *type)
+{
+ if (address == 0 && length != 0)
+ {
+ return gdbscm_make_out_of_range_error
+ (NULL, 0, scm_from_int (length),
+ _("cannot create a lazy string with address 0x0"
+ " and a non-zero length"));
+ }
+
+ if (type == NULL)
+ {
+ return gdbscm_make_out_of_range_error
+ (NULL, 0, scm_from_int (0), _("a lazy string's type cannot be NULL"));
+ }
+
+ return lsscm_make_lazy_string_smob (address, length, encoding, type);
+}
+
+/* Returns the <gdb:lazy-string> smob in SELF.
+ Throws an exception if SELF is not a <gdb:lazy-string> object. */
+
+static SCM
+lsscm_get_lazy_string_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (lsscm_is_lazy_string (self), self, arg_pos, func_name,
+ lazy_string_smob_name);
+
+ return self;
+}
+\f
+/* Lazy string methods. */
+
+/* (lazy-string-address <gdb:lazy-string>) -> address */
+
+static SCM
+gdbscm_lazy_string_address (SCM self)
+{
+ SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
+
+ return gdbscm_scm_from_ulongest (ls_smob->address);
+}
+
+/* (lazy-string-length <gdb:lazy-string>) -> integer */
+
+static SCM
+gdbscm_lazy_string_length (SCM self)
+{
+ SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
+
+ return scm_from_int (ls_smob->length);
+}
+
+/* (lazy-string-encoding <gdb:lazy-string>) -> string */
+
+static SCM
+gdbscm_lazy_string_encoding (SCM self)
+{
+ SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
+
+ /* An encoding can be set to NULL by the user, so check first.
+ If NULL return #f. */
+ if (ls_smob != NULL)
+ return gdbscm_scm_from_c_string (ls_smob->encoding);
+ return SCM_BOOL_F;
+}
+
+/* (lazy-string-type <gdb:lazy-string>) -> <gdb:type> */
+
+static SCM
+gdbscm_lazy_string_type (SCM self)
+{
+ SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
+
+ return tyscm_scm_from_type (ls_smob->type);
+}
+
+/* (lazy-string->value <gdb:lazy-string>) -> <gdb:value> */
+
+static SCM
+gdbscm_lazy_string_to_value (SCM self)
+{
+ SCM ls_scm = lsscm_get_lazy_string_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ lazy_string_smob *ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (ls_scm);
+ struct value *value = NULL;
+ volatile struct gdb_exception except;
+
+ if (ls_smob->address == 0)
+ {
+ gdbscm_throw (gdbscm_make_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
+ _("cannot create a value from NULL")));
+ }
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ value = value_at_lazy (ls_smob->type, ls_smob->address);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return vlscm_scm_from_value (value);
+}
+
+/* A "safe" version of gdbscm_lazy_string_to_value for use by
+ vlscm_convert_typed_value_from_scheme.
+ The result, upon success, is the value of <gdb:lazy-string> STRING.
+ ARG_POS is the argument position of STRING in the original Scheme
+ function call, used in exception text.
+ If there's an error, NULL is returned and a <gdb:exception> object
+ is stored in *except_scmp.
+
+ Note: The result is still "lazy". The caller must call value_fetch_lazy
+ to actually fetch the value. */
+
+struct value *
+lsscm_safe_lazy_string_to_value (SCM string, int arg_pos,
+ const char *func_name, SCM *except_scmp)
+{
+ lazy_string_smob *ls_smob;
+ struct value *value = NULL;
+ volatile struct gdb_exception except;
+
+ gdb_assert (lsscm_is_lazy_string (string));
+
+ ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (string);
+ *except_scmp = SCM_BOOL_F;
+
+ if (ls_smob->address == 0)
+ {
+ *except_scmp
+ = gdbscm_make_out_of_range_error (FUNC_NAME, SCM_ARG1, string,
+ _("cannot create a value from NULL"));
+ return NULL;
+ }
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ value = value_at_lazy (ls_smob->type, ls_smob->address);
+ }
+ if (except.reason < 0)
+ {
+ *except_scmp = gdbscm_scm_from_gdb_exception (except);
+ return NULL;
+ }
+
+ return value;
+}
+
+/* Print a lazy string to STREAM using val_print_string.
+ STRING must be a <gdb:lazy-string> object. */
+
+void
+lsscm_val_print_lazy_string (SCM string, struct ui_file *stream,
+ const struct value_print_options *options)
+{
+ lazy_string_smob *ls_smob;
+
+ gdb_assert (lsscm_is_lazy_string (string));
+
+ ls_smob = (lazy_string_smob *) SCM_SMOB_DATA (string);
+
+ val_print_string (ls_smob->type, ls_smob->encoding,
+ ls_smob->address, ls_smob->length,
+ stream, options);
+}
+\f
+/* Initialize the Scheme lazy-strings code. */
+
+static const scheme_function lazy_string_functions[] =
+{
+ { "lazy-string?", 1, 0, 0, gdbscm_lazy_string_p,
+ "\
+Return #t if the object is a <gdb:lazy-string> object." },
+
+ { "lazy-string-address", 1, 0, 0, gdbscm_lazy_string_address,
+ "\
+Return the address of the lazy-string." },
+
+ { "lazy-string-length", 1, 0, 0, gdbscm_lazy_string_length,
+ "\
+Return the length of the lazy-string.\n\
+If the length is -1 then the length is determined by the first null\n\
+of appropriate width." },
+
+ { "lazy-string-encoding", 1, 0, 0, gdbscm_lazy_string_encoding,
+ "\
+Return the encoding of the lazy-string." },
+
+ { "lazy-string-type", 1, 0, 0, gdbscm_lazy_string_type,
+ "\
+Return the <gdb:type> of the lazy-string." },
+
+ { "lazy-string->value", 1, 0, 0, gdbscm_lazy_string_to_value,
+ "\
+Return the <gdb:value> representation of the lazy-string." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_lazy_strings (void)
+{
+ lazy_string_smob_tag = gdbscm_make_smob_type (lazy_string_smob_name,
+ sizeof (lazy_string_smob));
+ scm_set_smob_mark (lazy_string_smob_tag, lsscm_mark_lazy_string_smob);
+ scm_set_smob_free (lazy_string_smob_tag, lsscm_free_lazy_string_smob);
+ scm_set_smob_print (lazy_string_smob_tag, lsscm_print_lazy_string_smob);
+
+ gdbscm_define_functions (lazy_string_functions, 1);
+}
--- /dev/null
+/* GDB/Scheme support for math operations on values.
+
+ 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 "arch-utils.h"
+#include "charset.h"
+#include "cp-abi.h"
+#include "doublest.h" /* Needed by dfp.h. */
+#include "expression.h" /* Needed by dfp.h. */
+#include "dfp.h"
+#include "gdb_assert.h"
+#include "symtab.h" /* Needed by language.h. */
+#include "language.h"
+#include "valprint.h"
+#include "value.h"
+#include "guile-internal.h"
+
+/* Note: Use target types here to remain consistent with the values system in
+ GDB (which uses target arithmetic). */
+
+enum valscm_unary_opcode
+{
+ VALSCM_NOT,
+ VALSCM_NEG,
+ VALSCM_NOP,
+ VALSCM_ABS,
+ /* Note: This is Scheme's "logical not", not GDB's.
+ GDB calls this UNOP_COMPLEMENT. */
+ VALSCM_LOGNOT
+};
+
+enum valscm_binary_opcode
+{
+ VALSCM_ADD,
+ VALSCM_SUB,
+ VALSCM_MUL,
+ VALSCM_DIV,
+ VALSCM_REM,
+ VALSCM_MOD,
+ VALSCM_POW,
+ VALSCM_LSH,
+ VALSCM_RSH,
+ VALSCM_MIN,
+ VALSCM_MAX,
+ VALSCM_BITAND,
+ VALSCM_BITOR,
+ VALSCM_BITXOR
+};
+
+/* If TYPE is a reference, return the target; otherwise return TYPE. */
+#define STRIP_REFERENCE(TYPE) \
+ ((TYPE_CODE (TYPE) == TYPE_CODE_REF) ? (TYPE_TARGET_TYPE (TYPE)) : (TYPE))
+
+/* Returns a value object which is the result of applying the operation
+ specified by OPCODE to the given argument.
+ If there's an error a Scheme exception is thrown. */
+
+static SCM
+vlscm_unop (enum valscm_unary_opcode opcode, SCM x, const char *func_name)
+{
+ struct gdbarch *gdbarch = get_current_arch ();
+ const struct language_defn *language = current_language;
+ struct value *arg1;
+ SCM result = SCM_BOOL_F;
+ struct value *res_val = NULL;
+ SCM except_scm;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
+ &except_scm, gdbarch, language);
+ if (arg1 == NULL)
+ {
+ do_cleanups (cleanups);
+ gdbscm_throw (except_scm);
+ }
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ switch (opcode)
+ {
+ case VALSCM_NOT:
+ /* Alas gdb and guile use the opposite meaning for "logical not". */
+ {
+ struct type *type = language_bool_type (language, gdbarch);
+ res_val
+ = value_from_longest (type, (LONGEST) value_logical_not (arg1));
+ }
+ break;
+ case VALSCM_NEG:
+ res_val = value_neg (arg1);
+ break;
+ case VALSCM_NOP:
+ /* Seemingly a no-op, but if X was a Scheme value it is now
+ a <gdb:value> object. */
+ res_val = arg1;
+ break;
+ case VALSCM_ABS:
+ if (value_less (arg1, value_zero (value_type (arg1), not_lval)))
+ res_val = value_neg (arg1);
+ else
+ res_val = arg1;
+ break;
+ case VALSCM_LOGNOT:
+ res_val = value_complement (arg1);
+ break;
+ default:
+ gdb_assert_not_reached ("unsupported operation");
+ }
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ gdb_assert (res_val != NULL);
+ result = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* Returns a value object which is the result of applying the operation
+ specified by OPCODE to the given arguments.
+ If there's an error a Scheme exception is thrown. */
+
+static SCM
+vlscm_binop (enum valscm_binary_opcode opcode, SCM x, SCM y,
+ const char *func_name)
+{
+ struct gdbarch *gdbarch = get_current_arch ();
+ const struct language_defn *language = current_language;
+ struct value *arg1, *arg2;
+ SCM result = SCM_BOOL_F;
+ struct value *res_val = NULL;
+ SCM except_scm;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ arg1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
+ &except_scm, gdbarch, language);
+ if (arg1 == NULL)
+ {
+ do_cleanups (cleanups);
+ gdbscm_throw (except_scm);
+ }
+ arg2 = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y,
+ &except_scm, gdbarch, language);
+ if (arg2 == NULL)
+ {
+ do_cleanups (cleanups);
+ gdbscm_throw (except_scm);
+ }
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ switch (opcode)
+ {
+ case VALSCM_ADD:
+ {
+ struct type *ltype = value_type (arg1);
+ struct type *rtype = value_type (arg2);
+
+ CHECK_TYPEDEF (ltype);
+ ltype = STRIP_REFERENCE (ltype);
+ CHECK_TYPEDEF (rtype);
+ rtype = STRIP_REFERENCE (rtype);
+
+ if (TYPE_CODE (ltype) == TYPE_CODE_PTR
+ && is_integral_type (rtype))
+ res_val = value_ptradd (arg1, value_as_long (arg2));
+ else if (TYPE_CODE (rtype) == TYPE_CODE_PTR
+ && is_integral_type (ltype))
+ res_val = value_ptradd (arg2, value_as_long (arg1));
+ else
+ res_val = value_binop (arg1, arg2, BINOP_ADD);
+ }
+ break;
+ case VALSCM_SUB:
+ {
+ struct type *ltype = value_type (arg1);
+ struct type *rtype = value_type (arg2);
+
+ CHECK_TYPEDEF (ltype);
+ ltype = STRIP_REFERENCE (ltype);
+ CHECK_TYPEDEF (rtype);
+ rtype = STRIP_REFERENCE (rtype);
+
+ if (TYPE_CODE (ltype) == TYPE_CODE_PTR
+ && TYPE_CODE (rtype) == TYPE_CODE_PTR)
+ {
+ /* A ptrdiff_t for the target would be preferable here. */
+ res_val
+ = value_from_longest (builtin_type (gdbarch)->builtin_long,
+ value_ptrdiff (arg1, arg2));
+ }
+ else if (TYPE_CODE (ltype) == TYPE_CODE_PTR
+ && is_integral_type (rtype))
+ res_val = value_ptradd (arg1, - value_as_long (arg2));
+ else
+ res_val = value_binop (arg1, arg2, BINOP_SUB);
+ }
+ break;
+ case VALSCM_MUL:
+ res_val = value_binop (arg1, arg2, BINOP_MUL);
+ break;
+ case VALSCM_DIV:
+ res_val = value_binop (arg1, arg2, BINOP_DIV);
+ break;
+ case VALSCM_REM:
+ res_val = value_binop (arg1, arg2, BINOP_REM);
+ break;
+ case VALSCM_MOD:
+ res_val = value_binop (arg1, arg2, BINOP_MOD);
+ break;
+ case VALSCM_POW:
+ res_val = value_binop (arg1, arg2, BINOP_EXP);
+ break;
+ case VALSCM_LSH:
+ res_val = value_binop (arg1, arg2, BINOP_LSH);
+ break;
+ case VALSCM_RSH:
+ res_val = value_binop (arg1, arg2, BINOP_RSH);
+ break;
+ case VALSCM_MIN:
+ res_val = value_binop (arg1, arg2, BINOP_MIN);
+ break;
+ case VALSCM_MAX:
+ res_val = value_binop (arg1, arg2, BINOP_MAX);
+ break;
+ case VALSCM_BITAND:
+ res_val = value_binop (arg1, arg2, BINOP_BITWISE_AND);
+ break;
+ case VALSCM_BITOR:
+ res_val = value_binop (arg1, arg2, BINOP_BITWISE_IOR);
+ break;
+ case VALSCM_BITXOR:
+ res_val = value_binop (arg1, arg2, BINOP_BITWISE_XOR);
+ break;
+ default:
+ gdb_assert_not_reached ("unsupported operation");
+ }
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ gdb_assert (res_val != NULL);
+ result = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value-add x y) -> <gdb:value> */
+
+static SCM
+gdbscm_value_add (SCM x, SCM y)
+{
+ return vlscm_binop (VALSCM_ADD, x, y, FUNC_NAME);
+}
+
+/* (value-sub x y) -> <gdb:value> */
+
+static SCM
+gdbscm_value_sub (SCM x, SCM y)
+{
+ return vlscm_binop (VALSCM_SUB, x, y, FUNC_NAME);
+}
+
+/* (value-mul x y) -> <gdb:value> */
+
+static SCM
+gdbscm_value_mul (SCM x, SCM y)
+{
+ return vlscm_binop (VALSCM_MUL, x, y, FUNC_NAME);
+}
+
+/* (value-div x y) -> <gdb:value> */
+
+static SCM
+gdbscm_value_div (SCM x, SCM y)
+{
+ return vlscm_binop (VALSCM_DIV, x, y, FUNC_NAME);
+}
+
+/* (value-rem x y) -> <gdb:value> */
+
+static SCM
+gdbscm_value_rem (SCM x, SCM y)
+{
+ return vlscm_binop (VALSCM_REM, x, y, FUNC_NAME);
+}
+
+/* (value-mod x y) -> <gdb:value> */
+
+static SCM
+gdbscm_value_mod (SCM x, SCM y)
+{
+ return vlscm_binop (VALSCM_MOD, x, y, FUNC_NAME);
+}
+
+/* (value-pow x y) -> <gdb:value> */
+
+static SCM
+gdbscm_value_pow (SCM x, SCM y)
+{
+ return vlscm_binop (VALSCM_POW, x, y, FUNC_NAME);
+}
+
+/* (value-neg x) -> <gdb:value> */
+
+static SCM
+gdbscm_value_neg (SCM x)
+{
+ return vlscm_unop (VALSCM_NEG, x, FUNC_NAME);
+}
+
+/* (value-pos x) -> <gdb:value> */
+
+static SCM
+gdbscm_value_pos (SCM x)
+{
+ return vlscm_unop (VALSCM_NOP, x, FUNC_NAME);
+}
+
+/* (value-abs x) -> <gdb:value> */
+
+static SCM
+gdbscm_value_abs (SCM x)
+{
+ return vlscm_unop (VALSCM_ABS, x, FUNC_NAME);
+}
+
+/* (value-lsh x y) -> <gdb:value> */
+
+static SCM
+gdbscm_value_lsh (SCM x, SCM y)
+{
+ return vlscm_binop (VALSCM_LSH, x, y, FUNC_NAME);
+}
+
+/* (value-rsh x y) -> <gdb:value> */
+
+static SCM
+gdbscm_value_rsh (SCM x, SCM y)
+{
+ return vlscm_binop (VALSCM_RSH, x, y, FUNC_NAME);
+}
+
+/* (value-min x y) -> <gdb:value> */
+
+static SCM
+gdbscm_value_min (SCM x, SCM y)
+{
+ return vlscm_binop (VALSCM_MIN, x, y, FUNC_NAME);
+}
+
+/* (value-max x y) -> <gdb:value> */
+
+static SCM
+gdbscm_value_max (SCM x, SCM y)
+{
+ return vlscm_binop (VALSCM_MAX, x, y, FUNC_NAME);
+}
+
+/* (value-not x) -> <gdb:value> */
+
+static SCM
+gdbscm_value_not (SCM x)
+{
+ return vlscm_unop (VALSCM_NOT, x, FUNC_NAME);
+}
+
+/* (value-lognot x) -> <gdb:value> */
+
+static SCM
+gdbscm_value_lognot (SCM x)
+{
+ return vlscm_unop (VALSCM_LOGNOT, x, FUNC_NAME);
+}
+
+/* (value-logand x y) -> <gdb:value> */
+
+static SCM
+gdbscm_value_logand (SCM x, SCM y)
+{
+ return vlscm_binop (VALSCM_BITAND, x, y, FUNC_NAME);
+}
+
+/* (value-logior x y) -> <gdb:value> */
+
+static SCM
+gdbscm_value_logior (SCM x, SCM y)
+{
+ return vlscm_binop (VALSCM_BITOR, x, y, FUNC_NAME);
+}
+
+/* (value-logxor x y) -> <gdb:value> */
+
+static SCM
+gdbscm_value_logxor (SCM x, SCM y)
+{
+ return vlscm_binop (VALSCM_BITXOR, x, y, FUNC_NAME);
+}
+
+/* Utility to perform all value comparisons.
+ If there's an error a Scheme exception is thrown. */
+
+static SCM
+vlscm_rich_compare (int op, SCM x, SCM y, const char *func_name)
+{
+ struct gdbarch *gdbarch = get_current_arch ();
+ const struct language_defn *language = current_language;
+ struct value *v1, *v2;
+ int result = 0;
+ SCM except_scm;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ v1 = vlscm_convert_value_from_scheme (func_name, SCM_ARG1, x,
+ &except_scm, gdbarch, language);
+ if (v1 == NULL)
+ {
+ do_cleanups (cleanups);
+ gdbscm_throw (except_scm);
+ }
+ v2 = vlscm_convert_value_from_scheme (func_name, SCM_ARG2, y,
+ &except_scm, gdbarch, language);
+ if (v2 == NULL)
+ {
+ do_cleanups (cleanups);
+ gdbscm_throw (except_scm);
+ }
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ switch (op)
+ {
+ case BINOP_LESS:
+ result = value_less (v1, v2);
+ break;
+ case BINOP_LEQ:
+ result = (value_less (v1, v2)
+ || value_equal (v1, v2));
+ break;
+ case BINOP_EQUAL:
+ result = value_equal (v1, v2);
+ break;
+ case BINOP_NOTEQUAL:
+ gdb_assert_not_reached ("not-equal not implemented");
+ case BINOP_GTR:
+ result = value_less (v2, v1);
+ break;
+ case BINOP_GEQ:
+ result = (value_less (v2, v1)
+ || value_equal (v1, v2));
+ break;
+ default:
+ gdb_assert_not_reached ("invalid <gdb:value> comparison");
+ }
+ }
+ do_cleanups (cleanups);
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return scm_from_bool (result);
+}
+
+/* (value=? x y) -> boolean
+ There is no "not-equal?" function (value!= ?) on purpose.
+ We're following string=?, etc. as our Guide here. */
+
+static SCM
+gdbscm_value_eq_p (SCM x, SCM y)
+{
+ return vlscm_rich_compare (BINOP_EQUAL, x, y, FUNC_NAME);
+}
+
+/* (value<? x y) -> boolean */
+
+static SCM
+gdbscm_value_lt_p (SCM x, SCM y)
+{
+ return vlscm_rich_compare (BINOP_LESS, x, y, FUNC_NAME);
+}
+
+/* (value<=? x y) -> boolean */
+
+static SCM
+gdbscm_value_le_p (SCM x, SCM y)
+{
+ return vlscm_rich_compare (BINOP_LEQ, x, y, FUNC_NAME);
+}
+
+/* (value>? x y) -> boolean */
+
+static SCM
+gdbscm_value_gt_p (SCM x, SCM y)
+{
+ return vlscm_rich_compare (BINOP_GTR, x, y, FUNC_NAME);
+}
+
+/* (value>=? x y) -> boolean */
+
+static SCM
+gdbscm_value_ge_p (SCM x, SCM y)
+{
+ return vlscm_rich_compare (BINOP_GEQ, x, y, FUNC_NAME);
+}
+\f
+/* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
+ Convert OBJ, a Scheme number, to a <gdb:value> object.
+ OBJ_ARG_POS is its position in the argument list, used in exception text.
+
+ TYPE is the result type. TYPE_ARG_POS is its position in
+ the argument list, used in exception text.
+ TYPE_SCM is Scheme object wrapping TYPE, used in exception text.
+
+ If the number isn't representable, e.g. it's too big, a <gdb:exception>
+ object is stored in *EXCEPT_SCMP and NULL is returned.
+ The conversion may throw a gdb error, e.g., if TYPE is invalid. */
+
+static struct value *
+vlscm_convert_typed_number (const char *func_name, int obj_arg_pos, SCM obj,
+ int type_arg_pos, SCM type_scm, struct type *type,
+ struct gdbarch *gdbarch, SCM *except_scmp)
+{
+ if (is_integral_type (type)
+ || TYPE_CODE (type) == TYPE_CODE_PTR)
+ {
+ if (TYPE_UNSIGNED (type))
+ {
+ ULONGEST max;
+
+ get_unsigned_type_max (type, &max);
+ if (!scm_is_unsigned_integer (obj, 0, max))
+ {
+ *except_scmp
+ = gdbscm_make_out_of_range_error (func_name,
+ obj_arg_pos, obj,
+ _("value out of range for type"));
+ return NULL;
+ }
+ return value_from_longest (type, gdbscm_scm_to_ulongest (obj));
+ }
+ else
+ {
+ LONGEST min, max;
+
+ get_signed_type_minmax (type, &min, &max);
+ if (!scm_is_signed_integer (obj, min, max))
+ {
+ *except_scmp
+ = gdbscm_make_out_of_range_error (func_name,
+ obj_arg_pos, obj,
+ _("value out of range for type"));
+ return NULL;
+ }
+ return value_from_longest (type, gdbscm_scm_to_longest (obj));
+ }
+ }
+ else if (TYPE_CODE (type) == TYPE_CODE_FLT)
+ return value_from_double (type, scm_to_double (obj));
+ else
+ {
+ *except_scmp = gdbscm_make_type_error (func_name, obj_arg_pos, obj,
+ NULL);
+ return NULL;
+ }
+}
+
+/* Return non-zero if OBJ, an integer, fits in TYPE. */
+
+static int
+vlscm_integer_fits_p (SCM obj, struct type *type)
+{
+ if (TYPE_UNSIGNED (type))
+ {
+ ULONGEST max;
+
+ /* If scm_is_unsigned_integer can't work with this type, just punt. */
+ if (TYPE_LENGTH (type) > sizeof (scm_t_uintmax))
+ return 0;
+ get_unsigned_type_max (type, &max);
+ return scm_is_unsigned_integer (obj, 0, max);
+ }
+ else
+ {
+ LONGEST min, max;
+
+ /* If scm_is_signed_integer can't work with this type, just punt. */
+ if (TYPE_LENGTH (type) > sizeof (scm_t_intmax))
+ return 0;
+ get_signed_type_minmax (type, &min, &max);
+ return scm_is_signed_integer (obj, min, max);
+ }
+}
+
+/* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
+ Convert OBJ, a Scheme number, to a <gdb:value> object.
+ OBJ_ARG_POS is its position in the argument list, used in exception text.
+
+ If OBJ is an integer, then the smallest int that will hold the value in
+ the following progression is chosen:
+ int, unsigned int, long, unsigned long, long long, unsigned long long.
+ Otherwise, if OBJ is a real number, then it is converted to a double.
+ Otherwise an exception is thrown.
+
+ If the number isn't representable, e.g. it's too big, a <gdb:exception>
+ object is stored in *EXCEPT_SCMP and NULL is returned. */
+
+static struct value *
+vlscm_convert_number (const char *func_name, int obj_arg_pos, SCM obj,
+ struct gdbarch *gdbarch, SCM *except_scmp)
+{
+ const struct builtin_type *bt = builtin_type (gdbarch);
+
+ /* One thing to keep in mind here is that we are interested in the
+ target's representation of OBJ, not the host's. */
+
+ if (scm_is_exact (obj) && scm_is_integer (obj))
+ {
+ if (vlscm_integer_fits_p (obj, bt->builtin_int))
+ return value_from_longest (bt->builtin_int,
+ gdbscm_scm_to_longest (obj));
+ if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_int))
+ return value_from_longest (bt->builtin_unsigned_int,
+ gdbscm_scm_to_ulongest (obj));
+ if (vlscm_integer_fits_p (obj, bt->builtin_long))
+ return value_from_longest (bt->builtin_long,
+ gdbscm_scm_to_longest (obj));
+ if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long))
+ return value_from_longest (bt->builtin_unsigned_long,
+ gdbscm_scm_to_ulongest (obj));
+ if (vlscm_integer_fits_p (obj, bt->builtin_long_long))
+ return value_from_longest (bt->builtin_long_long,
+ gdbscm_scm_to_longest (obj));
+ if (vlscm_integer_fits_p (obj, bt->builtin_unsigned_long_long))
+ return value_from_longest (bt->builtin_unsigned_long_long,
+ gdbscm_scm_to_ulongest (obj));
+ }
+ else if (scm_is_real (obj))
+ return value_from_double (bt->builtin_double, scm_to_double (obj));
+
+ *except_scmp = gdbscm_make_out_of_range_error (func_name, obj_arg_pos, obj,
+ _("value not a number representable on the target"));
+ return NULL;
+}
+
+/* Subroutine of vlscm_convert_typed_value_from_scheme to simplify it.
+ Convert BV, a Scheme bytevector, to a <gdb:value> object.
+
+ TYPE, if non-NULL, is the result type. Otherwise, a vector of type
+ uint8_t is used.
+ TYPE_SCM is Scheme object wrapping TYPE, used in exception text,
+ or #f if TYPE is NULL.
+
+ If the bytevector isn't the same size as the type, then a <gdb:exception>
+ object is stored in *EXCEPT_SCMP, and NULL is returned. */
+
+static struct value *
+vlscm_convert_bytevector (SCM bv, struct type *type, SCM type_scm,
+ int arg_pos, const char *func_name,
+ SCM *except_scmp, struct gdbarch *gdbarch)
+{
+ LONGEST length = SCM_BYTEVECTOR_LENGTH (bv);
+ struct value *value;
+
+ if (type == NULL)
+ {
+ type = builtin_type (gdbarch)->builtin_uint8;
+ type = lookup_array_range_type (type, 0, length);
+ make_vector_type (type);
+ }
+ type = check_typedef (type);
+ if (TYPE_LENGTH (type) != length)
+ {
+ *except_scmp = gdbscm_make_out_of_range_error (func_name, arg_pos,
+ type_scm,
+ _("size of type does not match size of bytevector"));
+ return NULL;
+ }
+
+ value = value_from_contents (type,
+ (gdb_byte *) SCM_BYTEVECTOR_CONTENTS (bv));
+ return value;
+}
+
+/* Convert OBJ, a Scheme value, to a <gdb:value> object.
+ OBJ_ARG_POS is its position in the argument list, used in exception text.
+
+ TYPE, if non-NULL, is the result type which must be compatible with
+ the value being converted.
+ If TYPE is NULL then a suitable default type is chosen.
+ TYPE_SCM is Scheme object wrapping TYPE, used in exception text,
+ or SCM_UNDEFINED if TYPE is NULL.
+ TYPE_ARG_POS is its position in the argument list, used in exception text,
+ or -1 if TYPE is NULL.
+
+ OBJ may also be a <gdb:value> object, in which case a copy is returned
+ and TYPE must be NULL.
+
+ If the value cannot be converted, NULL is returned and a gdb:exception
+ object is stored in *EXCEPT_SCMP.
+ Otherwise the new value is returned, added to the all_values chain. */
+
+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)
+{
+ struct value *value = NULL;
+ SCM except_scm = SCM_BOOL_F;
+ volatile struct gdb_exception except;
+
+ if (type == NULL)
+ {
+ gdb_assert (type_arg_pos == -1);
+ gdb_assert (SCM_UNBNDP (type_scm));
+ }
+
+ *except_scmp = SCM_BOOL_F;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (vlscm_is_value (obj))
+ {
+ if (type != NULL)
+ {
+ except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
+ type_scm,
+ _("No type allowed"));
+ value = NULL;
+ }
+ else
+ value = value_copy (vlscm_scm_to_value (obj));
+ }
+ else if (gdbscm_is_true (scm_bytevector_p (obj)))
+ {
+ value = vlscm_convert_bytevector (obj, type, type_scm,
+ obj_arg_pos, func_name,
+ &except_scm, gdbarch);
+ }
+ else if (gdbscm_is_bool (obj))
+ {
+ if (type != NULL
+ && !is_integral_type (type))
+ {
+ except_scm = gdbscm_make_type_error (func_name, type_arg_pos,
+ type_scm, NULL);
+ }
+ else
+ {
+ value = value_from_longest (type
+ ? type
+ : language_bool_type (language,
+ gdbarch),
+ gdbscm_is_true (obj));
+ }
+ }
+ else if (scm_is_number (obj))
+ {
+ if (type != NULL)
+ {
+ value = vlscm_convert_typed_number (func_name, obj_arg_pos, obj,
+ type_arg_pos, type_scm, type,
+ gdbarch, &except_scm);
+ }
+ else
+ {
+ value = vlscm_convert_number (func_name, obj_arg_pos, obj,
+ gdbarch, &except_scm);
+ }
+ }
+ else if (scm_is_string (obj))
+ {
+ char *s;
+ size_t len;
+ struct cleanup *cleanup;
+
+ if (type != NULL)
+ {
+ except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
+ type_scm,
+ _("No type allowed"));
+ value = NULL;
+ }
+ else
+ {
+ /* TODO: Provide option to specify conversion strategy. */
+ s = gdbscm_scm_to_string (obj, &len,
+ target_charset (gdbarch),
+ 0 /*non-strict*/,
+ &except_scm);
+ if (s != NULL)
+ {
+ cleanup = make_cleanup (xfree, s);
+ value
+ = value_cstring (s, len,
+ language_string_char_type (language,
+ gdbarch));
+ do_cleanups (cleanup);
+ }
+ else
+ value = NULL;
+ }
+ }
+ else if (lsscm_is_lazy_string (obj))
+ {
+ if (type != NULL)
+ {
+ except_scm = gdbscm_make_misc_error (func_name, type_arg_pos,
+ type_scm,
+ _("No type allowed"));
+ value = NULL;
+ }
+ else
+ {
+ value = lsscm_safe_lazy_string_to_value (obj, obj_arg_pos,
+ func_name,
+ &except_scm);
+ }
+ }
+ else /* OBJ isn't anything we support. */
+ {
+ except_scm = gdbscm_make_type_error (func_name, obj_arg_pos, obj,
+ NULL);
+ value = NULL;
+ }
+ }
+ if (except.reason < 0)
+ except_scm = gdbscm_scm_from_gdb_exception (except);
+
+ if (gdbscm_is_true (except_scm))
+ {
+ gdb_assert (value == NULL);
+ *except_scmp = except_scm;
+ }
+
+ return value;
+}
+
+/* Wrapper around vlscm_convert_typed_value_from_scheme for cases where there
+ is no supplied type. See vlscm_convert_typed_value_from_scheme for
+ details. */
+
+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)
+{
+ return vlscm_convert_typed_value_from_scheme (func_name, obj_arg_pos, obj,
+ -1, SCM_UNDEFINED, NULL,
+ except_scmp,
+ gdbarch, language);
+}
+\f
+/* Initialize value math support. */
+
+static const scheme_function math_functions[] =
+{
+ { "value-add", 2, 0, 0, gdbscm_value_add,
+ "\
+Return a + b." },
+
+ { "value-sub", 2, 0, 0, gdbscm_value_sub,
+ "\
+Return a - b." },
+
+ { "value-mul", 2, 0, 0, gdbscm_value_mul,
+ "\
+Return a * b." },
+
+ { "value-div", 2, 0, 0, gdbscm_value_div,
+ "\
+Return a / b." },
+
+ { "value-rem", 2, 0, 0, gdbscm_value_rem,
+ "\
+Return a % b." },
+
+ { "value-mod", 2, 0, 0, gdbscm_value_mod,
+ "\
+Return a mod b. See Knuth 1.2.4." },
+
+ { "value-pow", 2, 0, 0, gdbscm_value_pow,
+ "\
+Return pow (x, y)." },
+
+ { "value-not", 1, 0, 0, gdbscm_value_not,
+ "\
+Return !a." },
+
+ { "value-neg", 1, 0, 0, gdbscm_value_neg,
+ "\
+Return -a." },
+
+ { "value-pos", 1, 0, 0, gdbscm_value_pos,
+ "\
+Return a." },
+
+ { "value-abs", 1, 0, 0, gdbscm_value_abs,
+ "\
+Return abs (a)." },
+
+ { "value-lsh", 2, 0, 0, gdbscm_value_lsh,
+ "\
+Return a << b." },
+
+ { "value-rsh", 2, 0, 0, gdbscm_value_rsh,
+ "\
+Return a >> b." },
+
+ { "value-min", 2, 0, 0, gdbscm_value_min,
+ "\
+Return min (a, b)." },
+
+ { "value-max", 2, 0, 0, gdbscm_value_max,
+ "\
+Return max (a, b)." },
+
+ { "value-lognot", 1, 0, 0, gdbscm_value_lognot,
+ "\
+Return ~a." },
+
+ { "value-logand", 2, 0, 0, gdbscm_value_logand,
+ "\
+Return a & b." },
+
+ { "value-logior", 2, 0, 0, gdbscm_value_logior,
+ "\
+Return a | b." },
+
+ { "value-logxor", 2, 0, 0, gdbscm_value_logxor,
+ "\
+Return a ^ b." },
+
+ { "value=?", 2, 0, 0, gdbscm_value_eq_p,
+ "\
+Return a == b." },
+
+ { "value<?", 2, 0, 0, gdbscm_value_lt_p,
+ "\
+Return a < b." },
+
+ { "value<=?", 2, 0, 0, gdbscm_value_le_p,
+ "\
+Return a <= b." },
+
+ { "value>?", 2, 0, 0, gdbscm_value_gt_p,
+ "\
+Return a > b." },
+
+ { "value>=?", 2, 0, 0, gdbscm_value_ge_p,
+ "\
+Return a >= b." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_math (void)
+{
+ gdbscm_define_functions (math_functions, 1);
+}
--- /dev/null
+/* Scheme interface to objfiles.
+
+ 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 "objfiles.h"
+#include "language.h"
+#include "guile-internal.h"
+
+/* The <gdb:objfile> smob.
+ The typedef for this struct is in guile-internal.h. */
+
+struct _objfile_smob
+{
+ /* This always appears first. */
+ gdb_smob base;
+
+ /* The corresponding objfile. */
+ struct objfile *objfile;
+
+ /* The pretty-printer list of functions. */
+ SCM pretty_printers;
+
+ /* The <gdb:objfile> object we are contained in, needed to protect/unprotect
+ the object since a reference to it comes from non-gc-managed space
+ (the objfile). */
+ SCM containing_scm;
+};
+
+static const char objfile_smob_name[] = "gdb:objfile";
+
+/* The tag Guile knows the objfile smob by. */
+static scm_t_bits objfile_smob_tag;
+
+static const struct objfile_data *ofscm_objfile_data_key;
+
+/* Return the list of pretty-printers registered with O_SMOB. */
+
+SCM
+ofscm_objfile_smob_pretty_printers (objfile_smob *o_smob)
+{
+ return o_smob->pretty_printers;
+}
+\f
+/* Administrivia for objfile smobs. */
+
+/* The smob "mark" function for <gdb:objfile>. */
+
+static SCM
+ofscm_mark_objfile_smob (SCM self)
+{
+ objfile_smob *o_smob = (objfile_smob *) SCM_SMOB_DATA (self);
+
+ scm_gc_mark (o_smob->pretty_printers);
+
+ /* We don't mark containing_scm here. It is just a backlink to our
+ container, and is gc'protected until the objfile is deleted. */
+
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&o_smob->base);
+}
+
+/* The smob "print" function for <gdb:objfile>. */
+
+static int
+ofscm_print_objfile_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ objfile_smob *o_smob = (objfile_smob *) SCM_SMOB_DATA (self);
+
+ gdbscm_printf (port, "#<%s ", objfile_smob_name);
+ gdbscm_printf (port, "%s",
+ o_smob->objfile != NULL
+ ? objfile_name (o_smob->objfile)
+ : "{invalid}");
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to create a <gdb:objfile> object.
+ It's empty in the sense that an OBJFILE still needs to be associated
+ with it. */
+
+static SCM
+ofscm_make_objfile_smob (void)
+{
+ objfile_smob *o_smob = (objfile_smob *)
+ scm_gc_malloc (sizeof (objfile_smob), objfile_smob_name);
+ SCM o_scm;
+
+ o_smob->objfile = NULL;
+ o_smob->pretty_printers = SCM_EOL;
+ o_scm = scm_new_smob (objfile_smob_tag, (scm_t_bits) o_smob);
+ o_smob->containing_scm = o_scm;
+ gdbscm_init_gsmob (&o_smob->base);
+
+ return o_scm;
+}
+
+/* Clear the OBJFILE pointer in O_SMOB and unprotect the object from GC. */
+
+static void
+ofscm_release_objfile (objfile_smob *o_smob)
+{
+ o_smob->objfile = NULL;
+ scm_gc_unprotect_object (o_smob->containing_scm);
+}
+
+/* Objfile registry cleanup handler for when an objfile is deleted. */
+
+static void
+ofscm_handle_objfile_deleted (struct objfile *objfile, void *datum)
+{
+ objfile_smob *o_smob = datum;
+
+ gdb_assert (o_smob->objfile == objfile);
+
+ ofscm_release_objfile (o_smob);
+}
+
+/* Return non-zero if SCM is a <gdb:objfile> object. */
+
+static int
+ofscm_is_objfile (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (objfile_smob_tag, scm);
+}
+
+/* (objfile? object) -> boolean */
+
+static SCM
+gdbscm_objfile_p (SCM scm)
+{
+ return scm_from_bool (ofscm_is_objfile (scm));
+}
+
+/* Return a pointer to the objfile_smob that encapsulates OBJFILE,
+ creating one if necessary.
+ The result is cached so that we have only one copy per objfile. */
+
+objfile_smob *
+ofscm_objfile_smob_from_objfile (struct objfile *objfile)
+{
+ objfile_smob *o_smob;
+
+ o_smob = objfile_data (objfile, ofscm_objfile_data_key);
+ if (o_smob == NULL)
+ {
+ SCM o_scm = ofscm_make_objfile_smob ();
+
+ o_smob = (objfile_smob *) SCM_SMOB_DATA (o_scm);
+ o_smob->objfile = objfile;
+
+ set_objfile_data (objfile, ofscm_objfile_data_key, o_smob);
+ scm_gc_protect_object (o_smob->containing_scm);
+ }
+
+ return o_smob;
+}
+
+/* Return the <gdb:objfile> object that encapsulates OBJFILE. */
+
+SCM
+ofscm_scm_from_objfile (struct objfile *objfile)
+{
+ objfile_smob *o_smob = ofscm_objfile_smob_from_objfile (objfile);
+
+ return o_smob->containing_scm;
+}
+
+/* Returns the <gdb:objfile> object in SELF.
+ Throws an exception if SELF is not a <gdb:objfile> object. */
+
+static SCM
+ofscm_get_objfile_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (ofscm_is_objfile (self), self, arg_pos, func_name,
+ objfile_smob_name);
+
+ return self;
+}
+
+/* Returns a pointer to the objfile smob of SELF.
+ Throws an exception if SELF is not a <gdb:objfile> object. */
+
+static objfile_smob *
+ofscm_get_objfile_smob_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ SCM o_scm = ofscm_get_objfile_arg_unsafe (self, arg_pos, func_name);
+ objfile_smob *o_smob = (objfile_smob *) SCM_SMOB_DATA (o_scm);
+
+ return o_smob;
+}
+
+/* Return non-zero if objfile O_SMOB is valid. */
+
+static int
+ofscm_is_valid (objfile_smob *o_smob)
+{
+ return o_smob->objfile != NULL;
+}
+
+/* Return the objfile smob in SELF, verifying it's valid.
+ Throws an exception if SELF is not a <gdb:objfile> object or is invalid. */
+
+static objfile_smob *
+ofscm_get_valid_objfile_smob_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ objfile_smob *o_smob
+ = ofscm_get_objfile_smob_arg_unsafe (self, arg_pos, func_name);
+
+ if (!ofscm_is_valid (o_smob))
+ {
+ gdbscm_invalid_object_error (func_name, arg_pos, self,
+ _("<gdb:objfile>"));
+ }
+
+ return o_smob;
+}
+\f
+/* Objfile methods. */
+
+/* (objfile-valid? <gdb:objfile>) -> boolean
+ Returns #t if this object file still exists in GDB. */
+
+static SCM
+gdbscm_objfile_valid_p (SCM self)
+{
+ objfile_smob *o_smob
+ = ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_bool (o_smob->objfile != NULL);
+}
+
+/* (objfile-filename <gdb:objfile>) -> string
+ Returns the objfile's file name.
+ Throw's an exception if the underlying objfile is invalid. */
+
+static SCM
+gdbscm_objfile_filename (SCM self)
+{
+ objfile_smob *o_smob
+ = ofscm_get_valid_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return gdbscm_scm_from_c_string (objfile_name (o_smob->objfile));
+}
+
+/* (objfile-pretty-printers <gdb:objfile>) -> list
+ Returns the list of pretty-printers for this objfile. */
+
+static SCM
+gdbscm_objfile_pretty_printers (SCM self)
+{
+ objfile_smob *o_smob
+ = ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return o_smob->pretty_printers;
+}
+
+/* (set-objfile-pretty-printers! <gdb:objfile> list) -> unspecified
+ Set the pretty-printers for this objfile. */
+
+static SCM
+gdbscm_set_objfile_pretty_printers_x (SCM self, SCM printers)
+{
+ objfile_smob *o_smob
+ = ofscm_get_objfile_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (printers)), printers,
+ SCM_ARG2, FUNC_NAME, _("list"));
+
+ o_smob->pretty_printers = printers;
+
+ return SCM_UNSPECIFIED;
+}
+\f
+/* The "current" objfile. This is set when gdb detects that a new
+ objfile has been loaded. It is only set for the duration of a call to
+ gdbscm_source_objfile_script; it is NULL at other times. */
+static struct objfile *ofscm_current_objfile;
+
+/* Set the current objfile to OBJFILE and then read FILE named FILENAME
+ as Guile code. This does not throw any errors. If an exception
+ occurs Guile will print the backtrace.
+ This is the extension_language_script_ops.objfile_script_sourcer
+ "method". */
+
+void
+gdbscm_source_objfile_script (const struct extension_language_defn *extlang,
+ struct objfile *objfile, FILE *file,
+ const char *filename)
+{
+ char *msg;
+
+ ofscm_current_objfile = objfile;
+
+ msg = gdbscm_safe_source_script (filename);
+ if (msg != NULL)
+ {
+ fprintf_filtered (gdb_stderr, "%s", msg);
+ xfree (msg);
+ }
+
+ ofscm_current_objfile = NULL;
+}
+
+/* (current-objfile) -> <gdb:obfjile>
+ Return the current objfile, or #f if there isn't one.
+ Ideally this would be named ofscm_current_objfile, but that name is
+ taken by the variable recording the current objfile. */
+
+static SCM
+gdbscm_get_current_objfile (void)
+{
+ if (ofscm_current_objfile == NULL)
+ return SCM_BOOL_F;
+
+ return ofscm_scm_from_objfile (ofscm_current_objfile);
+}
+
+/* (objfiles) -> list
+ Return a list of all objfiles in the current program space. */
+
+static SCM
+gdbscm_objfiles (void)
+{
+ struct objfile *objf;
+ SCM result;
+
+ result = SCM_EOL;
+
+ ALL_OBJFILES (objf)
+ {
+ SCM item = ofscm_scm_from_objfile (objf);
+
+ result = scm_cons (item, result);
+ }
+
+ return scm_reverse_x (result, SCM_EOL);
+}
+\f
+/* Initialize the Scheme objfile support. */
+
+static const scheme_function objfile_functions[] =
+{
+ { "objfile?", 1, 0, 0, gdbscm_objfile_p,
+ "\
+Return #t if the object is a <gdb:objfile> object." },
+
+ { "objfile-valid?", 1, 0, 0, gdbscm_objfile_valid_p,
+ "\
+Return #t if the objfile is valid (hasn't been deleted from gdb)." },
+
+ { "objfile-filename", 1, 0, 0, gdbscm_objfile_filename,
+ "\
+Return the file name of the objfile." },
+
+ { "objfile-pretty-printers", 1, 0, 0, gdbscm_objfile_pretty_printers,
+ "\
+Return a list of pretty-printers of the objfile." },
+
+ { "set-objfile-pretty-printers!", 2, 0, 0,
+ gdbscm_set_objfile_pretty_printers_x,
+ "\
+Set the list of pretty-printers of the objfile." },
+
+ { "current-objfile", 0, 0, 0, gdbscm_get_current_objfile,
+ "\
+Return the current objfile if there is one or #f if there isn't one." },
+
+ { "objfiles", 0, 0, 0, gdbscm_objfiles,
+ "\
+Return a list of all objfiles in the current program space." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_objfiles (void)
+{
+ objfile_smob_tag
+ = gdbscm_make_smob_type (objfile_smob_name, sizeof (objfile_smob));
+ scm_set_smob_mark (objfile_smob_tag, ofscm_mark_objfile_smob);
+ scm_set_smob_print (objfile_smob_tag, ofscm_print_objfile_smob);
+
+ gdbscm_define_functions (objfile_functions, 1);
+
+ ofscm_objfile_data_key
+ = register_objfile_data_with_cleanup (NULL, ofscm_handle_objfile_deleted);
+}
--- /dev/null
+/* Support for connecting Guile's stdio to GDB's.
+ as well as r/w memory via ports.
+
+ Copyright (C) 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 "gdb_select.h"
+#include "interps.h"
+#include "target.h"
+#include "guile-internal.h"
+
+#ifdef HAVE_POLL
+#if defined (HAVE_POLL_H)
+#include <poll.h>
+#elif defined (HAVE_SYS_POLL_H)
+#include <sys/poll.h>
+#endif
+#endif
+
+/* A ui-file for sending output to Guile. */
+
+typedef struct
+{
+ int *magic;
+ SCM port;
+} ioscm_file_port;
+
+/* Data for a memory port. */
+
+typedef struct
+{
+ /* Bounds of memory range this port is allowed to access, inclusive.
+ To simplify overflow handling, an END of 0xff..ff is not allowed.
+ This also means a start address of 0xff..ff is also not allowed.
+ I can live with that. */
+ CORE_ADDR start, end;
+
+ /* (end - start + 1), recorded for convenience. */
+ ULONGEST size;
+
+ /* Think of this as the lseek value maintained by the kernel.
+ This value is always in the range [0, size]. */
+ ULONGEST current;
+
+ /* The size of the internal r/w buffers.
+ Scheme ports aren't a straightforward mapping to memory r/w.
+ Generally the user specifies how much to r/w and all access is
+ unbuffered. We don't try to provide equivalent access, but we allow
+ the user to specify these values to help get something similar. */
+ unsigned read_buf_size, write_buf_size;
+} ioscm_memory_port;
+
+/* Copies of the original system input/output/error ports.
+ These are recorded for debugging purposes. */
+static SCM orig_input_port_scm;
+static SCM orig_output_port_scm;
+static SCM orig_error_port_scm;
+
+/* This is the stdio port descriptor, scm_ptob_descriptor. */
+static scm_t_bits stdio_port_desc;
+
+/* Note: scm_make_port_type takes a char * instead of a const char *. */
+static /*const*/ char stdio_port_desc_name[] = "gdb:stdio-port";
+
+/* Names of each gdb port. */
+static const char input_port_name[] = "gdb:stdin";
+static const char output_port_name[] = "gdb:stdout";
+static const char error_port_name[] = "gdb:stderr";
+
+/* This is the actual port used from Guile.
+ We don't expose these to the user though, to ensure they're not
+ overwritten. */
+static SCM input_port_scm;
+static SCM output_port_scm;
+static SCM error_port_scm;
+
+/* Magic number to identify port ui-files.
+ Actually, the address of this variable is the magic number. */
+static int file_port_magic;
+
+/* Internal enum for specifying output port. */
+enum oport { GDB_STDOUT, GDB_STDERR };
+
+/* This is the memory port descriptor, scm_ptob_descriptor. */
+static scm_t_bits memory_port_desc;
+
+/* Note: scm_make_port_type takes a char * instead of a const char *. */
+static /*const*/ char memory_port_desc_name[] = "gdb:memory-port";
+
+/* The default amount of memory to fetch for each read/write request.
+ Scheme ports don't provide a way to specify the size of a read,
+ which is important to us to minimize the number of inferior interactions,
+ which over a remote link can be important. To compensate we augment the
+ port API with a new function that let's the user specify how much the next
+ read request should fetch. This is the initial value for each new port. */
+static const unsigned default_read_buf_size = 16;
+static const unsigned default_write_buf_size = 16;
+
+/* Arbitrarily limit memory port buffers to 1 byte to 4K. */
+static const unsigned min_memory_port_buf_size = 1;
+static const unsigned max_memory_port_buf_size = 4096;
+
+/* "out of range" error message for buf sizes. */
+static char *out_of_range_buf_size;
+
+/* Keywords used by open-memory. */
+static SCM mode_keyword;
+static SCM start_keyword;
+static SCM size_keyword;
+\f
+/* Helper to do the low level work of opening a port.
+ Newer versions of Guile (2.1.x) have scm_c_make_port. */
+
+static SCM
+ioscm_open_port (scm_t_bits port_type, long mode_bits)
+{
+ SCM port;
+
+#if 0 /* TODO: Guile doesn't export this. What to do? */
+ scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
+#endif
+
+ port = scm_new_port_table_entry (port_type);
+
+ SCM_SET_CELL_TYPE (port, port_type | mode_bits);
+
+#if 0 /* TODO: Guile doesn't export this. What to do? */
+ scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);
+#endif
+
+ return port;
+}
+\f
+/* Support for connecting Guile's stdio ports to GDB's stdio ports. */
+
+/* The scm_t_ptob_descriptor.input_waiting "method".
+ Return a lower bound on the number of bytes available for input. */
+
+static int
+ioscm_input_waiting (SCM port)
+{
+ int fdes = 0;
+
+ if (! scm_is_eq (port, input_port_scm))
+ return 0;
+
+#ifdef HAVE_POLL
+ {
+ /* This is copied from libguile/fports.c. */
+ struct pollfd pollfd = { fdes, POLLIN, 0 };
+ static int use_poll = -1;
+
+ if (use_poll < 0)
+ {
+ /* This is copied from event-loop.c: poll cannot be used for stdin on
+ m68k-motorola-sysv. */
+ struct pollfd test_pollfd = { fdes, POLLIN, 0 };
+
+ if (poll (&test_pollfd, 1, 0) == 1 && (test_pollfd.revents & POLLNVAL))
+ use_poll = 0;
+ else
+ use_poll = 1;
+ }
+
+ if (use_poll)
+ {
+ /* Guile doesn't export SIGINT hooks like Python does.
+ For now pass EINTR to scm_syserror, that's what fports.c does. */
+ if (poll (&pollfd, 1, 0) < 0)
+ scm_syserror (FUNC_NAME);
+
+ return pollfd.revents & POLLIN ? 1 : 0;
+ }
+ }
+ /* Fall through. */
+#endif
+
+ {
+ struct timeval timeout;
+ fd_set input_fds;
+ int num_fds = fdes + 1;
+ int num_found;
+
+ memset (&timeout, 0, sizeof (timeout));
+ FD_ZERO (&input_fds);
+ FD_SET (fdes, &input_fds);
+
+ num_found = gdb_select (num_fds, &input_fds, NULL, NULL, &timeout);
+ if (num_found < 0)
+ {
+ /* Guile doesn't export SIGINT hooks like Python does.
+ For now pass EINTR to scm_syserror, that's what fports.c does. */
+ scm_syserror (FUNC_NAME);
+ }
+ return num_found > 0 && FD_ISSET (fdes, &input_fds);
+ }
+}
+
+/* The scm_t_ptob_descriptor.fill_input "method". */
+
+static int
+ioscm_fill_input (SCM port)
+{
+ /* Borrowed from libguile/fports.c. */
+ long count;
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+
+ /* If we're called on stdout,stderr, punt. */
+ if (! scm_is_eq (port, input_port_scm))
+ return (scm_t_wchar) EOF; /* Set errno and return -1? */
+
+ gdb_flush (gdb_stdout);
+ gdb_flush (gdb_stderr);
+
+ count = ui_file_read (gdb_stdin, (char *) pt->read_buf, pt->read_buf_size);
+ if (count == -1)
+ scm_syserror (FUNC_NAME);
+ if (count == 0)
+ return (scm_t_wchar) EOF;
+
+ pt->read_pos = pt->read_buf;
+ pt->read_end = pt->read_buf + count;
+ return *pt->read_buf;
+}
+
+/* Like fputstrn_filtered, but don't escape characters, except nul.
+ Also like fputs_filtered, but a length is specified. */
+
+static void
+fputsn_filtered (const char *s, size_t size, struct ui_file *stream)
+{
+ size_t i;
+
+ for (i = 0; i < size; ++i)
+ {
+ if (s[i] == '\0')
+ fputs_filtered ("\\000", stream);
+ else
+ fputc_filtered (s[i], stream);
+ }
+}
+
+/* Write to gdb's stdout or stderr. */
+
+static void
+ioscm_write (SCM port, const void *data, size_t size)
+{
+ volatile struct gdb_exception except;
+
+ /* If we're called on stdin, punt. */
+ if (scm_is_eq (port, input_port_scm))
+ return;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (scm_is_eq (port, error_port_scm))
+ fputsn_filtered (data, size, gdb_stderr);
+ else
+ fputsn_filtered (data, size, gdb_stdout);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+}
+
+/* Flush gdb's stdout or stderr. */
+
+static void
+ioscm_flush (SCM port)
+{
+ /* If we're called on stdin, punt. */
+ if (scm_is_eq (port, input_port_scm))
+ return;
+
+ if (scm_is_eq (port, error_port_scm))
+ gdb_flush (gdb_stderr);
+ else
+ gdb_flush (gdb_stdout);
+}
+
+/* Initialize the gdb stdio port type.
+
+ N.B. isatty? will fail on these ports, it is only supported for file
+ ports. IWBN if we could "subclass" file ports. */
+
+static void
+ioscm_init_gdb_stdio_port (void)
+{
+ stdio_port_desc = scm_make_port_type (stdio_port_desc_name,
+ ioscm_fill_input, ioscm_write);
+
+ scm_set_port_input_waiting (stdio_port_desc, ioscm_input_waiting);
+ scm_set_port_flush (stdio_port_desc, ioscm_flush);
+}
+
+/* Subroutine of ioscm_make_gdb_stdio_port to simplify it.
+ Set up the buffers of port PORT.
+ MODE_BITS are the mode bits of PORT. */
+
+static void
+ioscm_init_stdio_buffers (SCM port, long mode_bits)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+#define GDB_STDIO_BUFFER_DEFAULT_SIZE 1024
+ int size = mode_bits & SCM_BUF0 ? 0 : GDB_STDIO_BUFFER_DEFAULT_SIZE;
+ int writing = (mode_bits & SCM_WRTNG) != 0;
+
+ /* This is heavily copied from scm_fport_buffer_add. */
+
+ if (!writing && size > 0)
+ {
+ pt->read_buf = scm_gc_malloc_pointerless (size, "port buffer");
+ pt->read_pos = pt->read_end = pt->read_buf;
+ pt->read_buf_size = size;
+ }
+ else
+ {
+ pt->read_pos = pt->read_buf = pt->read_end = &pt->shortbuf;
+ pt->read_buf_size = 1;
+ }
+
+ if (writing && size > 0)
+ {
+ pt->write_buf = scm_gc_malloc_pointerless (size, "port buffer");
+ pt->write_pos = pt->write_buf;
+ pt->write_buf_size = size;
+ }
+ else
+ {
+ pt->write_buf = pt->write_pos = &pt->shortbuf;
+ pt->write_buf_size = 1;
+ }
+ pt->write_end = pt->write_buf + pt->write_buf_size;
+}
+
+/* Create a gdb stdio port. */
+
+static SCM
+ioscm_make_gdb_stdio_port (int fd)
+{
+ int is_a_tty = isatty (fd);
+ const char *name;
+ long mode_bits;
+ SCM port;
+
+ switch (fd)
+ {
+ case 0:
+ name = input_port_name;
+ mode_bits = scm_mode_bits (is_a_tty ? "r0" : "r");
+ break;
+ case 1:
+ name = output_port_name;
+ mode_bits = scm_mode_bits (is_a_tty ? "w0" : "w");
+ break;
+ case 2:
+ name = error_port_name;
+ mode_bits = scm_mode_bits (is_a_tty ? "w0" : "w");
+ break;
+ default:
+ gdb_assert_not_reached ("bad stdio file descriptor");
+ }
+
+ port = ioscm_open_port (stdio_port_desc, mode_bits);
+
+ scm_set_port_filename_x (port, gdbscm_scm_from_c_string (name));
+
+ ioscm_init_stdio_buffers (port, mode_bits);
+
+ return port;
+}
+
+/* (stdio-port? object) -> boolean */
+
+static SCM
+gdbscm_stdio_port_p (SCM scm)
+{
+ /* This is copied from SCM_FPORTP. */
+ return scm_from_bool (!SCM_IMP (scm)
+ && (SCM_TYP16 (scm) == stdio_port_desc));
+}
+\f
+/* GDB's ports are accessed via functions to keep them read-only. */
+
+/* (input-port) -> port */
+
+static SCM
+gdbscm_input_port (void)
+{
+ return input_port_scm;
+}
+
+/* (output-port) -> port */
+
+static SCM
+gdbscm_output_port (void)
+{
+ return output_port_scm;
+}
+
+/* (error-port) -> port */
+
+static SCM
+gdbscm_error_port (void)
+{
+ return error_port_scm;
+}
+\f
+/* Support for sending GDB I/O to Guile ports. */
+
+static void
+ioscm_file_port_delete (struct ui_file *file)
+{
+ ioscm_file_port *stream = ui_file_data (file);
+
+ if (stream->magic != &file_port_magic)
+ internal_error (__FILE__, __LINE__,
+ _("ioscm_file_port_delete: bad magic number"));
+ xfree (stream);
+}
+
+static void
+ioscm_file_port_rewind (struct ui_file *file)
+{
+ ioscm_file_port *stream = ui_file_data (file);
+
+ if (stream->magic != &file_port_magic)
+ internal_error (__FILE__, __LINE__,
+ _("ioscm_file_port_rewind: bad magic number"));
+
+ scm_truncate_file (stream->port, 0);
+}
+
+static void
+ioscm_file_port_put (struct ui_file *file,
+ ui_file_put_method_ftype *write,
+ void *dest)
+{
+ ioscm_file_port *stream = ui_file_data (file);
+
+ if (stream->magic != &file_port_magic)
+ internal_error (__FILE__, __LINE__,
+ _("ioscm_file_port_put: bad magic number"));
+
+ /* This function doesn't meld with ports very well. */
+}
+
+static void
+ioscm_file_port_write (struct ui_file *file,
+ const char *buffer,
+ long length_buffer)
+{
+ ioscm_file_port *stream = ui_file_data (file);
+
+ if (stream->magic != &file_port_magic)
+ internal_error (__FILE__, __LINE__,
+ _("ioscm_pot_file_write: bad magic number"));
+
+ scm_c_write (stream->port, buffer, length_buffer);
+}
+
+/* Return a ui_file that writes to PORT. */
+
+static struct ui_file *
+ioscm_file_port_new (SCM port)
+{
+ ioscm_file_port *stream = XCNEW (ioscm_file_port);
+ struct ui_file *file = ui_file_new ();
+
+ set_ui_file_data (file, stream, ioscm_file_port_delete);
+ set_ui_file_rewind (file, ioscm_file_port_rewind);
+ set_ui_file_put (file, ioscm_file_port_put);
+ set_ui_file_write (file, ioscm_file_port_write);
+ stream->magic = &file_port_magic;
+ stream->port = port;
+
+ return file;
+}
+\f
+/* Helper routine for with-{output,error}-to-port. */
+
+static SCM
+ioscm_with_output_to_port_worker (SCM port, SCM thunk, enum oport oport,
+ const char *func_name)
+{
+ struct ui_file *port_file;
+ struct cleanup *cleanups;
+ SCM result;
+
+ SCM_ASSERT_TYPE (gdbscm_is_true (scm_output_port_p (port)), port,
+ SCM_ARG1, func_name, _("output port"));
+ SCM_ASSERT_TYPE (gdbscm_is_true (scm_thunk_p (thunk)), thunk,
+ SCM_ARG2, func_name, _("thunk"));
+
+ cleanups = set_batch_flag_and_make_cleanup_restore_page_info ();
+
+ make_cleanup_restore_integer (&interpreter_async);
+ interpreter_async = 0;
+
+ port_file = ioscm_file_port_new (port);
+
+ make_cleanup_ui_file_delete (port_file);
+
+ if (oport == GDB_STDERR)
+ {
+ make_cleanup_restore_ui_file (&gdb_stderr);
+ gdb_stderr = port_file;
+ }
+ else
+ {
+ make_cleanup_restore_ui_file (&gdb_stdout);
+
+ if (ui_out_redirect (current_uiout, port_file) < 0)
+ warning (_("Current output protocol does not support redirection"));
+ else
+ make_cleanup_ui_out_redirect_pop (current_uiout);
+
+ gdb_stdout = port_file;
+ }
+
+ result = gdbscm_safe_call_0 (thunk, NULL);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (%with-gdb-output-to-port port thunk) -> object
+ This function is experimental.
+ IWBN to not include "gdb" in the name, but it would collide with a standard
+ procedure, and it's common to import the gdb module without a prefix.
+ There are ways around this, but they're more cumbersome.
+
+ This has % in the name because it's experimental, and we want the
+ user-visible version to come from module (gdb experimental). */
+
+static SCM
+gdbscm_percent_with_gdb_output_to_port (SCM port, SCM thunk)
+{
+ return ioscm_with_output_to_port_worker (port, thunk, GDB_STDOUT, FUNC_NAME);
+}
+
+/* (%with-gdb-error-to-port port thunk) -> object
+ This function is experimental.
+ IWBN to not include "gdb" in the name, but it would collide with a standard
+ procedure, and it's common to import the gdb module without a prefix.
+ There are ways around this, but they're more cumbersome.
+
+ This has % in the name because it's experimental, and we want the
+ user-visible version to come from module (gdb experimental). */
+
+static SCM
+gdbscm_percent_with_gdb_error_to_port (SCM port, SCM thunk)
+{
+ return ioscm_with_output_to_port_worker (port, thunk, GDB_STDERR, FUNC_NAME);
+}
+\f
+/* Support for r/w memory via ports. */
+
+/* Perform an "lseek" to OFFSET,WHENCE on memory port IOMEM.
+ OFFSET must be in the range [0,size].
+ The result is non-zero for success, zero for failure. */
+
+static int
+ioscm_lseek_address (ioscm_memory_port *iomem, LONGEST offset, int whence)
+{
+ CORE_ADDR new_current;
+
+ gdb_assert (iomem->current <= iomem->size);
+
+ switch (whence)
+ {
+ case SEEK_CUR:
+ /* Catch over/underflow. */
+ if ((offset < 0 && iomem->current + offset > iomem->current)
+ || (offset >= 0 && iomem->current + offset < iomem->current))
+ return 0;
+ new_current = iomem->current + offset;
+ break;
+ case SEEK_SET:
+ new_current = offset;
+ break;
+ case SEEK_END:
+ if (offset == 0)
+ {
+ new_current = iomem->size;
+ break;
+ }
+ /* TODO: Not supported yet. */
+ return 0;
+ default:
+ return 0;
+ }
+
+ if (new_current > iomem->size)
+ return 0;
+ iomem->current = new_current;
+ return 1;
+}
+
+/* "fill_input" method for memory ports. */
+
+static int
+gdbscm_memory_port_fill_input (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ ioscm_memory_port *iomem = (ioscm_memory_port *) SCM_STREAM (port);
+ size_t to_read;
+
+ /* "current" is the offset of the first byte we want to read. */
+ if (iomem->current >= iomem->size)
+ return EOF;
+
+ /* Don't read outside the allowed memory range. */
+ to_read = pt->read_buf_size;
+ if (to_read > iomem->size - iomem->current)
+ to_read = iomem->size - iomem->current;
+
+ if (target_read_memory (iomem->start + iomem->current, pt->read_buf,
+ to_read) != 0)
+ gdbscm_memory_error (FUNC_NAME, _("error reading memory"), SCM_EOL);
+
+ pt->read_pos = pt->read_buf;
+ pt->read_end = pt->read_buf + to_read;
+ iomem->current += to_read;
+ return *pt->read_buf;
+}
+
+/* "end_input" method for memory ports.
+ Clear the read buffer and adjust the file position for unread bytes. */
+
+static void
+gdbscm_memory_port_end_input (SCM port, int offset)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ ioscm_memory_port *iomem = (ioscm_memory_port *) SCM_STREAM (port);
+ size_t remaining = pt->read_end - pt->read_pos;
+
+ /* Note: Use of "int offset" is specified by Guile ports API. */
+ if ((offset < 0 && remaining + offset > remaining)
+ || (offset > 0 && remaining + offset < remaining))
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, 0, scm_from_int (offset),
+ _("overflow in offset calculation"));
+ }
+ offset += remaining;
+
+ if (offset > 0)
+ {
+ pt->read_pos = pt->read_end;
+ /* Throw error if unread-char used at beginning of file
+ then attempting to write. Seems correct. */
+ if (!ioscm_lseek_address (iomem, -offset, SEEK_CUR))
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, 0, scm_from_int (offset),
+ _("bad offset"));
+ }
+ }
+
+ pt->rw_active = SCM_PORT_NEITHER;
+}
+
+/* "flush" method for memory ports. */
+
+static void
+gdbscm_memory_port_flush (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ ioscm_memory_port *iomem = (ioscm_memory_port *) SCM_STREAM (port);
+ size_t to_write = pt->write_pos - pt->write_buf;
+
+ if (to_write == 0)
+ return;
+
+ /* There's no way to indicate a short write, so if the request goes past
+ the end of the port's memory range, flag an error. */
+ if (to_write > iomem->size - iomem->current)
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, 0,
+ gdbscm_scm_from_ulongest (to_write),
+ _("writing beyond end of memory range"));
+ }
+
+ if (target_write_memory (iomem->start + iomem->current, pt->write_buf,
+ to_write) != 0)
+ gdbscm_memory_error (FUNC_NAME, _("error writing memory"), SCM_EOL);
+
+ iomem->current += to_write;
+ pt->write_pos = pt->write_buf;
+ pt->rw_active = SCM_PORT_NEITHER;
+}
+
+/* "write" method for memory ports. */
+
+static void
+gdbscm_memory_port_write (SCM port, const void *data, size_t size)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ ioscm_memory_port *iomem = (ioscm_memory_port *) SCM_STREAM (port);
+ const char *input = (char *) data;
+
+ /* We could get fancy here, and try to buffer the request since we're
+ buffering anyway. But there's currently no need. */
+
+ /* First flush what's currently buffered. */
+ gdbscm_memory_port_flush (port);
+
+ /* There's no way to indicate a short write, so if the request goes past
+ the end of the port's memory range, flag an error. */
+ if (size > iomem->size - iomem->current)
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, 0, gdbscm_scm_from_ulongest (size),
+ _("writing beyond end of memory range"));
+ }
+
+ if (target_write_memory (iomem->start + iomem->current, data, size) != 0)
+ gdbscm_memory_error (FUNC_NAME, _("error writing memory"), SCM_EOL);
+
+ iomem->current += size;
+}
+
+/* "seek" method for memory ports. */
+
+static scm_t_off
+gdbscm_memory_port_seek (SCM port, scm_t_off offset, int whence)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ ioscm_memory_port *iomem = (ioscm_memory_port *) SCM_STREAM (port);
+ CORE_ADDR result;
+ int rc;
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ {
+ if (offset != 0 || whence != SEEK_CUR)
+ {
+ gdbscm_memory_port_flush (port);
+ rc = ioscm_lseek_address (iomem, offset, whence);
+ result = iomem->current;
+ }
+ else
+ {
+ /* Read current position without disturbing the buffer,
+ but flag an error if what's in the buffer goes outside the
+ allowed range. */
+ CORE_ADDR current = iomem->current;
+ size_t delta = pt->write_pos - pt->write_buf;
+
+ if (current + delta < current
+ || current + delta > iomem->size + 1)
+ rc = 0;
+ else
+ {
+ result = current + delta;
+ rc = 1;
+ }
+ }
+ }
+ else if (pt->rw_active == SCM_PORT_READ)
+ {
+ if (offset != 0 || whence != SEEK_CUR)
+ {
+ scm_end_input (port);
+ rc = ioscm_lseek_address (iomem, offset, whence);
+ result = iomem->current;
+ }
+ else
+ {
+ /* Read current position without disturbing the buffer
+ (particularly the unread-char buffer). */
+ CORE_ADDR current = iomem->current;
+ size_t remaining = pt->read_end - pt->read_pos;
+
+ if (current - remaining > current
+ || current - remaining < iomem->start)
+ rc = 0;
+ else
+ {
+ result = current - remaining;
+ rc = 1;
+ }
+
+ if (rc != 0 && pt->read_buf == pt->putback_buf)
+ {
+ size_t saved_remaining = pt->saved_read_end - pt->saved_read_pos;
+
+ if (result - saved_remaining > result
+ || result - saved_remaining < iomem->start)
+ rc = 0;
+ else
+ result -= saved_remaining;
+ }
+ }
+ }
+ else /* SCM_PORT_NEITHER */
+ {
+ rc = ioscm_lseek_address (iomem, offset, whence);
+ result = iomem->current;
+ }
+
+ if (rc == 0)
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, 0,
+ gdbscm_scm_from_longest (offset),
+ _("bad seek"));
+ }
+
+ /* TODO: The Guile API doesn't support 32x64. We can't fix that here,
+ and there's no need to throw an error if the new address can't be
+ represented in a scm_t_off. But we could return something less
+ clumsy. */
+ return result;
+}
+
+/* "close" method for memory ports. */
+
+static int
+gdbscm_memory_port_close (SCM port)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ ioscm_memory_port *iomem = (ioscm_memory_port *) SCM_STREAM (port);
+
+ gdbscm_memory_port_flush (port);
+
+ if (pt->read_buf == pt->putback_buf)
+ pt->read_buf = pt->saved_read_buf;
+ xfree (pt->read_buf);
+ xfree (pt->write_buf);
+ scm_gc_free (iomem, sizeof (*iomem), "memory port");
+
+ return 0;
+}
+
+/* "free" method for memory ports. */
+
+static size_t
+gdbscm_memory_port_free (SCM port)
+{
+ gdbscm_memory_port_close (port);
+
+ return 0;
+}
+
+/* "print" method for memory ports. */
+
+static int
+gdbscm_memory_port_print (SCM exp, SCM port, scm_print_state *pstate)
+{
+ ioscm_memory_port *iomem = (ioscm_memory_port *) SCM_STREAM (exp);
+ char *type = SCM_PTOBNAME (SCM_PTOBNUM (exp));
+
+ scm_puts ("#<", port);
+ scm_print_port_mode (exp, port);
+ /* scm_print_port_mode includes a trailing space. */
+ gdbscm_printf (port, "%s %s-%s", type,
+ hex_string (iomem->start), hex_string (iomem->end));
+ scm_putc ('>', port);
+ return 1;
+}
+
+/* Create the port type used for memory. */
+
+static void
+ioscm_init_memory_port_type (void)
+{
+ memory_port_desc = scm_make_port_type (memory_port_desc_name,
+ gdbscm_memory_port_fill_input,
+ gdbscm_memory_port_write);
+
+ scm_set_port_end_input (memory_port_desc, gdbscm_memory_port_end_input);
+ scm_set_port_flush (memory_port_desc, gdbscm_memory_port_flush);
+ scm_set_port_seek (memory_port_desc, gdbscm_memory_port_seek);
+ scm_set_port_close (memory_port_desc, gdbscm_memory_port_close);
+ scm_set_port_free (memory_port_desc, gdbscm_memory_port_free);
+ scm_set_port_print (memory_port_desc, gdbscm_memory_port_print);
+}
+
+/* Helper for gdbscm_open_memory to parse the mode bits.
+ An exception is thrown if MODE is invalid. */
+
+static long
+ioscm_parse_mode_bits (const char *func_name, const char *mode)
+{
+ const char *p;
+ long mode_bits;
+
+ if (*mode != 'r' && *mode != 'w')
+ {
+ gdbscm_out_of_range_error (func_name, 0,
+ gdbscm_scm_from_c_string (mode),
+ _("bad mode string"));
+ }
+ for (p = mode + 1; *p != '\0'; ++p)
+ {
+ switch (*p)
+ {
+ case 'b':
+ case '+':
+ break;
+ default:
+ gdbscm_out_of_range_error (func_name, 0,
+ gdbscm_scm_from_c_string (mode),
+ _("bad mode string"));
+ }
+ }
+
+ /* Kinda awkward to convert the mode from SCM -> string only to have Guile
+ convert it back to SCM, but that's the API we have to work with. */
+ mode_bits = scm_mode_bits ((char *) mode);
+
+ return mode_bits;
+}
+
+/* Helper for gdbscm_open_memory to finish initializing the port.
+ The port has address range [start,end].
+ To simplify overflow handling, an END of 0xff..ff is not allowed.
+ This also means a start address of 0xff..f is also not allowed.
+ I can live with that. */
+
+static void
+ioscm_init_memory_port (SCM port, CORE_ADDR start, CORE_ADDR end)
+{
+ scm_t_port *pt;
+ ioscm_memory_port *iomem;
+
+ gdb_assert (start <= end);
+ gdb_assert (end < ~(CORE_ADDR) 0);
+
+ iomem = (ioscm_memory_port *) scm_gc_malloc_pointerless (sizeof (*iomem),
+ "memory port");
+
+ iomem->start = start;
+ iomem->end = end;
+ iomem->size = end - start + 1;
+ iomem->current = 0;
+ iomem->read_buf_size = default_read_buf_size;
+ iomem->write_buf_size = default_write_buf_size;
+
+ pt = SCM_PTAB_ENTRY (port);
+ /* Match the expectation of `binary-port?'. */
+ pt->encoding = NULL;
+ pt->rw_random = 1;
+ pt->read_buf_size = iomem->read_buf_size;
+ pt->read_buf = xmalloc (pt->read_buf_size);
+ pt->read_pos = pt->read_end = pt->read_buf;
+ pt->write_buf_size = iomem->write_buf_size;
+ pt->write_buf = xmalloc (pt->write_buf_size);
+ pt->write_pos = pt->write_buf;
+ pt->write_end = pt->write_buf + pt->write_buf_size;
+
+ SCM_SETSTREAM (port, iomem);
+}
+
+/* Re-initialize a memory port, updating its read/write buffer sizes.
+ An exception is thrown if data is still buffered, except in the case
+ where the buffer size isn't changing (since that's just a nop). */
+
+static void
+ioscm_reinit_memory_port (SCM port, size_t read_buf_size,
+ size_t write_buf_size, const char *func_name)
+{
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ ioscm_memory_port *iomem = (ioscm_memory_port *) SCM_STREAM (port);
+
+ gdb_assert (read_buf_size >= min_memory_port_buf_size
+ && read_buf_size <= max_memory_port_buf_size);
+ gdb_assert (write_buf_size >= min_memory_port_buf_size
+ && write_buf_size <= max_memory_port_buf_size);
+
+ /* First check if anything is buffered. */
+
+ if (read_buf_size != pt->read_buf_size
+ && pt->read_end != pt->read_buf)
+ {
+ scm_misc_error (func_name, _("read buffer not empty: ~a"),
+ scm_list_1 (port));
+ }
+
+ if (write_buf_size != pt->write_buf_size
+ && pt->write_pos != pt->write_buf)
+ {
+ scm_misc_error (func_name, _("write buffer not empty: ~a"),
+ scm_list_1 (port));
+ }
+
+ /* Now we can update the buffer sizes, but only if the size has changed. */
+
+ if (read_buf_size != pt->read_buf_size)
+ {
+ iomem->read_buf_size = read_buf_size;
+ pt->read_buf_size = read_buf_size;
+ xfree (pt->read_buf);
+ pt->read_buf = xmalloc (pt->read_buf_size);
+ pt->read_pos = pt->read_end = pt->read_buf;
+ }
+
+ if (write_buf_size != pt->write_buf_size)
+ {
+ iomem->write_buf_size = write_buf_size;
+ pt->write_buf_size = write_buf_size;
+ xfree (pt->write_buf);
+ pt->write_buf = xmalloc (pt->write_buf_size);
+ pt->write_pos = pt->write_buf;
+ pt->write_end = pt->write_buf + pt->write_buf_size;
+ }
+}
+
+/* (open-memory [#:mode string] [#:start address] [#:size integer]) -> port
+ Return a port that can be used for reading and writing memory.
+ MODE is a string, and must be one of "r", "w", or "r+".
+ For compatibility "b" (binary) may also be present, but we ignore it:
+ memory ports are binary only.
+
+ TODO: Support "0" (unbuffered)? Only support "0" (always unbuffered)?
+
+ The chunk of memory that can be accessed can be bounded.
+ If both START,SIZE are unspecified, all of memory can be accessed.
+ If only START is specified, all of memory from that point on can be
+ accessed. If only SIZE if specified, all memory in [0,SIZE) can be
+ accessed. If both are specified, all memory in [START,START+SIZE) can be
+ accessed.
+
+ Note: If it becomes useful enough we can later add #:end as an alternative
+ to #:size. For now it is left out.
+
+ The result is a Scheme port, and its semantics are a bit odd for accessing
+ memory (e.g., unget), but we don't try to hide this. It's a port.
+
+ N.B. Seeks on the port must be in the range [0,size).
+ This is for similarity with bytevector ports, and so that one can seek
+ to the first byte. */
+
+static SCM
+gdbscm_open_memory (SCM rest)
+{
+ const SCM keywords[] = {
+ mode_keyword, start_keyword, size_keyword, SCM_BOOL_F
+ };
+ char *mode = NULL;
+ CORE_ADDR start = 0;
+ CORE_ADDR end;
+ int mode_arg_pos = -1, start_arg_pos = -1, size_arg_pos = -1;
+ ULONGEST size;
+ SCM port;
+ long mode_bits;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "#sUU", rest,
+ &mode_arg_pos, &mode,
+ &start_arg_pos, &start,
+ &size_arg_pos, &size);
+
+ scm_dynwind_begin (0);
+
+ if (mode == NULL)
+ mode = xstrdup ("r");
+ scm_dynwind_free (mode);
+
+ if (start == ~(CORE_ADDR) 0)
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, scm_from_int (-1),
+ _("start address of 0xff..ff not allowed"));
+ }
+
+ if (size_arg_pos > 0)
+ {
+ if (size == 0)
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, 0, scm_from_int (0),
+ "zero size");
+ }
+ /* For now be strict about start+size overflowing. If it becomes
+ a nuisance we can relax things later. */
+ if (start + size < start)
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, 0,
+ scm_list_2 (gdbscm_scm_from_ulongest (start),
+ gdbscm_scm_from_ulongest (size)),
+ _("start+size overflows"));
+ }
+ end = start + size - 1;
+ if (end == ~(CORE_ADDR) 0)
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, 0,
+ scm_list_2 (gdbscm_scm_from_ulongest (start),
+ gdbscm_scm_from_ulongest (size)),
+ _("end address of 0xff..ff not allowed"));
+ }
+ }
+ else
+ end = (~(CORE_ADDR) 0) - 1;
+
+ mode_bits = ioscm_parse_mode_bits (FUNC_NAME, mode);
+
+ port = ioscm_open_port (memory_port_desc, mode_bits);
+
+ ioscm_init_memory_port (port, start, end);
+
+ scm_dynwind_end ();
+
+ /* TODO: Set the file name as "memory-start-end"? */
+ return port;
+}
+
+/* Return non-zero if OBJ is a memory port. */
+
+static int
+gdbscm_is_memory_port (SCM obj)
+{
+ return !SCM_IMP (obj) && (SCM_TYP16 (obj) == memory_port_desc);
+}
+
+/* (memory-port? obj) -> boolean */
+
+static SCM
+gdbscm_memory_port_p (SCM obj)
+{
+ return scm_from_bool (gdbscm_is_memory_port (obj));
+}
+
+/* (memory-port-range port) -> (start end) */
+
+static SCM
+gdbscm_memory_port_range (SCM port)
+{
+ ioscm_memory_port *iomem;
+
+ SCM_ASSERT_TYPE (gdbscm_is_memory_port (port), port, SCM_ARG1, FUNC_NAME,
+ memory_port_desc_name);
+
+ iomem = (ioscm_memory_port *) SCM_STREAM (port);
+ return scm_list_2 (gdbscm_scm_from_ulongest (iomem->start),
+ gdbscm_scm_from_ulongest (iomem->end));
+}
+
+/* (memory-port-read-buffer-size port) -> integer */
+
+static SCM
+gdbscm_memory_port_read_buffer_size (SCM port)
+{
+ ioscm_memory_port *iomem;
+
+ SCM_ASSERT_TYPE (gdbscm_is_memory_port (port), port, SCM_ARG1, FUNC_NAME,
+ memory_port_desc_name);
+
+ iomem = (ioscm_memory_port *) SCM_STREAM (port);
+ return scm_from_uint (iomem->read_buf_size);
+}
+
+/* (set-memory-port-read-buffer-size! port size) -> unspecified
+ An exception is thrown if read data is still buffered. */
+
+static SCM
+gdbscm_set_memory_port_read_buffer_size_x (SCM port, SCM size)
+{
+ ioscm_memory_port *iomem;
+
+ SCM_ASSERT_TYPE (gdbscm_is_memory_port (port), port, SCM_ARG1, FUNC_NAME,
+ memory_port_desc_name);
+ SCM_ASSERT_TYPE (scm_is_integer (size), size, SCM_ARG2, FUNC_NAME,
+ _("integer"));
+
+ if (!scm_is_unsigned_integer (size, min_memory_port_buf_size,
+ max_memory_port_buf_size))
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, size,
+ out_of_range_buf_size);
+ }
+
+ iomem = (ioscm_memory_port *) SCM_STREAM (port);
+ ioscm_reinit_memory_port (port, scm_to_uint (size), iomem->write_buf_size,
+ FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+
+/* (memory-port-write-buffer-size port) -> integer */
+
+static SCM
+gdbscm_memory_port_write_buffer_size (SCM port)
+{
+ ioscm_memory_port *iomem;
+
+ SCM_ASSERT_TYPE (gdbscm_is_memory_port (port), port, SCM_ARG1, FUNC_NAME,
+ memory_port_desc_name);
+
+ iomem = (ioscm_memory_port *) SCM_STREAM (port);
+ return scm_from_uint (iomem->write_buf_size);
+}
+
+/* (set-memory-port-write-buffer-size! port size) -> unspecified
+ An exception is thrown if write data is still buffered. */
+
+static SCM
+gdbscm_set_memory_port_write_buffer_size_x (SCM port, SCM size)
+{
+ ioscm_memory_port *iomem;
+
+ SCM_ASSERT_TYPE (gdbscm_is_memory_port (port), port, SCM_ARG1, FUNC_NAME,
+ memory_port_desc_name);
+ SCM_ASSERT_TYPE (scm_is_integer (size), size, SCM_ARG2, FUNC_NAME,
+ _("integer"));
+
+ if (!scm_is_unsigned_integer (size, min_memory_port_buf_size,
+ max_memory_port_buf_size))
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG2, size,
+ out_of_range_buf_size);
+ }
+
+ iomem = (ioscm_memory_port *) SCM_STREAM (port);
+ ioscm_reinit_memory_port (port, iomem->read_buf_size, scm_to_uint (size),
+ FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+\f
+/* Initialize gdb ports. */
+
+static const scheme_function port_functions[] =
+{
+ { "input-port", 0, 0, 0, gdbscm_input_port,
+ "\
+Return gdb's input port." },
+
+ { "output-port", 0, 0, 0, gdbscm_output_port,
+ "\
+Return gdb's output port." },
+
+ { "error-port", 0, 0, 0, gdbscm_error_port,
+ "\
+Return gdb's error port." },
+
+ { "stdio-port?", 1, 0, 0, gdbscm_stdio_port_p,
+ "\
+Return #t if the object is a gdb:stdio-port." },
+
+ { "open-memory", 0, 0, 1, gdbscm_open_memory,
+ "\
+Return a port that can be used for reading/writing inferior memory.\n\
+\n\
+ Arguments: [#:mode string] [#:start address] [#:size integer]\n\
+ Returns: A port object." },
+
+ { "memory-port?", 1, 0, 0, gdbscm_memory_port_p,
+ "\
+Return #t if the object is a memory port." },
+
+ { "memory-port-range", 1, 0, 0, gdbscm_memory_port_range,
+ "\
+Return the memory range of the port as (start end)." },
+
+ { "memory-port-read-buffer-size", 1, 0, 0,
+ gdbscm_memory_port_read_buffer_size,
+ "\
+Return the size of the read buffer for the memory port." },
+
+ { "set-memory-port-read-buffer-size!", 2, 0, 0,
+ gdbscm_set_memory_port_read_buffer_size_x,
+ "\
+Set the size of the read buffer for the memory port.\n\
+\n\
+ Arguments: port integer\n\
+ Returns: unspecified." },
+
+ { "memory-port-write-buffer-size", 1, 0, 0,
+ gdbscm_memory_port_write_buffer_size,
+ "\
+Return the size of the write buffer for the memory port." },
+
+ { "set-memory-port-write-buffer-size!", 2, 0, 0,
+ gdbscm_set_memory_port_write_buffer_size_x,
+ "\
+Set the size of the write buffer for the memory port.\n\
+\n\
+ Arguments: port integer\n\
+ Returns: unspecified." },
+
+ END_FUNCTIONS
+};
+
+static const scheme_function private_port_functions[] =
+{
+#if 0 /* TODO */
+ { "%with-gdb-input-from-port", 2, 0, 0,
+ gdbscm_percent_with_gdb_input_from_port,
+ "\
+Temporarily set GDB's input port to PORT and then invoke THUNK.\n\
+\n\
+ Arguments: port thunk\n\
+ Returns: The result of calling THUNK.\n\
+\n\
+This procedure is experimental." },
+#endif
+
+ { "%with-gdb-output-to-port", 2, 0, 0,
+ gdbscm_percent_with_gdb_output_to_port,
+ "\
+Temporarily set GDB's output port to PORT and then invoke THUNK.\n\
+\n\
+ Arguments: port thunk\n\
+ Returns: The result of calling THUNK.\n\
+\n\
+This procedure is experimental." },
+
+ { "%with-gdb-error-to-port", 2, 0, 0,
+ gdbscm_percent_with_gdb_error_to_port,
+ "\
+Temporarily set GDB's error port to PORT and then invoke THUNK.\n\
+\n\
+ Arguments: port thunk\n\
+ Returns: The result of calling THUNK.\n\
+\n\
+This procedure is experimental." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_ports (void)
+{
+ /* Save the original stdio ports for debugging purposes. */
+
+ orig_input_port_scm = scm_current_input_port ();
+ orig_output_port_scm = scm_current_output_port ();
+ orig_error_port_scm = scm_current_error_port ();
+
+ /* Set up the stdio ports. */
+
+ ioscm_init_gdb_stdio_port ();
+ input_port_scm = ioscm_make_gdb_stdio_port (0);
+ output_port_scm = ioscm_make_gdb_stdio_port (1);
+ error_port_scm = ioscm_make_gdb_stdio_port (2);
+
+ /* Set up memory ports. */
+
+ ioscm_init_memory_port_type ();
+
+ /* Install the accessor functions. */
+
+ gdbscm_define_functions (port_functions, 1);
+ gdbscm_define_functions (private_port_functions, 0);
+
+ /* Keyword args for open-memory. */
+
+ mode_keyword = scm_from_latin1_keyword ("mode");
+ start_keyword = scm_from_latin1_keyword ("start");
+ size_keyword = scm_from_latin1_keyword ("size");
+
+ /* Error message text for "out of range" memory port buffer sizes. */
+
+ out_of_range_buf_size = xstrprintf ("size not between %u - %u",
+ min_memory_port_buf_size,
+ max_memory_port_buf_size);
+}
--- /dev/null
+/* GDB/Scheme pretty-printing.
+
+ 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 "charset.h"
+#include "gdb_assert.h"
+#include "symtab.h" /* Needed by language.h. */
+#include "language.h"
+#include "objfiles.h"
+#include "value.h"
+#include "valprint.h"
+#include "guile-internal.h"
+
+/* Return type of print_string_repr. */
+
+enum string_repr_result
+{
+ /* The string method returned None. */
+ STRING_REPR_NONE,
+ /* The string method had an error. */
+ STRING_REPR_ERROR,
+ /* Everything ok. */
+ STRING_REPR_OK
+};
+
+/* Display hints. */
+
+enum display_hint
+{
+ /* No display hint. */
+ HINT_NONE,
+ /* The display hint has a bad value. */
+ HINT_ERROR,
+ /* Print as an array. */
+ HINT_ARRAY,
+ /* Print as a map. */
+ HINT_MAP,
+ /* Print as a string. */
+ HINT_STRING
+};
+
+/* The <gdb:pretty-printer> smob. */
+
+typedef struct
+{
+ /* This must appear first. */
+ gdb_smob base;
+
+ /* A string representing the name of the printer. */
+ SCM name;
+
+ /* A boolean indicating whether the printer is enabled. */
+ SCM enabled;
+
+ /* A procedure called to look up the printer for the given value.
+ The procedure is called as (lookup gdb:pretty-printer value).
+ The result should either be a gdb:pretty-printer object that will print
+ the value, or #f if the value is not recognized. */
+ SCM lookup;
+
+ /* Note: Attaching subprinters to this smob is left to Scheme. */
+} pretty_printer_smob;
+
+/* The <gdb:pretty-printer-worker> smob. */
+
+typedef struct
+{
+ /* This must appear first. */
+ gdb_smob base;
+
+ /* Either #f or one of the supported display hints: map, array, string.
+ If neither of those then the display hint is ignored (treated as #f). */
+ SCM display_hint;
+
+ /* A procedure called to pretty-print the value.
+ (lambda (printer) ...) -> string | <gdb:lazy-string> | <gdb:value> */
+ SCM to_string;
+
+ /* A procedure called to print children of the value.
+ (lambda (printer) ...) -> <gdb:iterator>
+ The iterator returns a pair for each iteration: (name . value),
+ where "value" can have the same types as to_string. */
+ SCM children;
+} pretty_printer_worker_smob;
+
+static const char pretty_printer_smob_name[] =
+ "gdb:pretty-printer";
+static const char pretty_printer_worker_smob_name[] =
+ "gdb:pretty-printer-worker";
+
+/* The tag Guile knows the pretty-printer smobs by. */
+static scm_t_bits pretty_printer_smob_tag;
+static scm_t_bits pretty_printer_worker_smob_tag;
+
+/* Global list of pretty-printers. */
+static const char pretty_printer_list_name[] = "*pretty-printers*";
+
+/* The *pretty-printer* variable. */
+static SCM pretty_printer_list_var;
+
+/* gdb:pp-type-error. */
+static SCM pp_type_error_symbol;
+
+/* Pretty-printer display hints are specified by strings. */
+static SCM ppscm_map_string;
+static SCM ppscm_array_string;
+static SCM ppscm_string_string;
+\f
+/* Administrivia for pretty-printer matcher smobs. */
+
+/* The smob "mark" function for <gdb:pretty-printer>. */
+
+static SCM
+ppscm_mark_pretty_printer_smob (SCM self)
+{
+ pretty_printer_smob *pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (self);
+
+ scm_gc_mark (pp_smob->name);
+ scm_gc_mark (pp_smob->enabled);
+ scm_gc_mark (pp_smob->lookup);
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&pp_smob->base);
+}
+
+/* The smob "print" function for <gdb:pretty-printer>. */
+
+static int
+ppscm_print_pretty_printer_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ pretty_printer_smob *pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (self);
+
+ gdbscm_printf (port, "#<%s ", pretty_printer_smob_name);
+ scm_write (pp_smob->name, port);
+ scm_puts (gdbscm_is_true (pp_smob->enabled) ? " enabled" : " disabled",
+ port);
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* (make-pretty-printer string procedure) -> <gdb:pretty-printer> */
+
+static SCM
+gdbscm_make_pretty_printer (SCM name, SCM lookup)
+{
+ pretty_printer_smob *pp_smob = (pretty_printer_smob *)
+ scm_gc_malloc (sizeof (pretty_printer_smob),
+ pretty_printer_smob_name);
+ SCM smob;
+
+ SCM_ASSERT_TYPE (scm_is_string (name), name, SCM_ARG1, FUNC_NAME,
+ _("string"));
+ SCM_ASSERT_TYPE (gdbscm_is_procedure (lookup), lookup, SCM_ARG2, FUNC_NAME,
+ _("procedure"));
+
+ pp_smob->name = name;
+ pp_smob->lookup = lookup;
+ pp_smob->enabled = SCM_BOOL_T;
+ smob = scm_new_smob (pretty_printer_smob_tag, (scm_t_bits) pp_smob);
+ gdbscm_init_gsmob (&pp_smob->base);
+
+ return smob;
+}
+
+/* Return non-zero if SCM is a <gdb:pretty-printer> object. */
+
+static int
+ppscm_is_pretty_printer (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (pretty_printer_smob_tag, scm);
+}
+
+/* (pretty-printer? object) -> boolean */
+
+static SCM
+gdbscm_pretty_printer_p (SCM scm)
+{
+ return scm_from_bool (ppscm_is_pretty_printer (scm));
+}
+
+/* Returns the <gdb:pretty-printer> object in SELF.
+ Throws an exception if SELF is not a <gdb:pretty-printer> object. */
+
+static SCM
+ppscm_get_pretty_printer_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ SCM_ASSERT_TYPE (ppscm_is_pretty_printer (self), self, arg_pos, func_name,
+ pretty_printer_smob_name);
+
+ return self;
+}
+
+/* Returns a pointer to the pretty-printer smob of SELF.
+ Throws an exception if SELF is not a <gdb:pretty-printer> object. */
+
+static pretty_printer_smob *
+ppscm_get_pretty_printer_smob_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ SCM pp_scm = ppscm_get_pretty_printer_arg_unsafe (self, arg_pos, func_name);
+ pretty_printer_smob *pp_smob
+ = (pretty_printer_smob *) SCM_SMOB_DATA (pp_scm);
+
+ return pp_smob;
+}
+\f
+/* Pretty-printer methods. */
+
+/* (pretty-printer-enabled? <gdb:pretty-printer>) -> boolean */
+
+static SCM
+gdbscm_pretty_printer_enabled_p (SCM self)
+{
+ pretty_printer_smob *pp_smob
+ = ppscm_get_pretty_printer_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return pp_smob->enabled;
+}
+
+/* (set-pretty-printer-enabled! <gdb:pretty-printer> boolean)
+ -> unspecified */
+
+static SCM
+gdbscm_set_pretty_printer_enabled_x (SCM self, SCM enabled)
+{
+ pretty_printer_smob *pp_smob
+ = ppscm_get_pretty_printer_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ pp_smob->enabled = scm_from_bool (gdbscm_is_true (enabled));
+
+ return SCM_UNSPECIFIED;
+}
+\f
+/* Administrivia for pretty-printer-worker smobs.
+ These are created when a matcher recognizes a value. */
+
+/* The smob "mark" function for <gdb:pretty-printer-worker>. */
+
+static SCM
+ppscm_mark_pretty_printer_worker_smob (SCM self)
+{
+ pretty_printer_worker_smob *w_smob
+ = (pretty_printer_worker_smob *) SCM_SMOB_DATA (self);
+
+ scm_gc_mark (w_smob->display_hint);
+ scm_gc_mark (w_smob->to_string);
+ scm_gc_mark (w_smob->children);
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&w_smob->base);
+}
+
+/* The smob "print" function for <gdb:pretty-printer-worker>. */
+
+static int
+ppscm_print_pretty_printer_worker_smob (SCM self, SCM port,
+ scm_print_state *pstate)
+{
+ pretty_printer_worker_smob *w_smob
+ = (pretty_printer_worker_smob *) SCM_SMOB_DATA (self);
+
+ gdbscm_printf (port, "#<%s ", pretty_printer_worker_smob_name);
+ scm_write (w_smob->display_hint, port);
+ scm_puts (" ", port);
+ scm_write (w_smob->to_string, port);
+ scm_puts (" ", port);
+ scm_write (w_smob->children, port);
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* (make-pretty-printer-worker string procedure procedure)
+ -> <gdb:pretty-printer-worker> */
+
+static SCM
+gdbscm_make_pretty_printer_worker (SCM display_hint, SCM to_string,
+ SCM children)
+{
+ pretty_printer_worker_smob *w_smob = (pretty_printer_worker_smob *)
+ scm_gc_malloc (sizeof (pretty_printer_worker_smob),
+ pretty_printer_worker_smob_name);
+ SCM w_scm;
+
+ w_smob->display_hint = display_hint;
+ w_smob->to_string = to_string;
+ w_smob->children = children;
+ w_scm = scm_new_smob (pretty_printer_worker_smob_tag, (scm_t_bits) w_smob);
+ gdbscm_init_gsmob (&w_smob->base);
+ return w_scm;
+}
+
+/* Return non-zero if SCM is a <gdb:pretty-printer-worker> object. */
+
+static int
+ppscm_is_pretty_printer_worker (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (pretty_printer_worker_smob_tag, scm);
+}
+
+/* (pretty-printer-worker? object) -> boolean */
+
+static SCM
+gdbscm_pretty_printer_worker_p (SCM scm)
+{
+ return scm_from_bool (ppscm_is_pretty_printer_worker (scm));
+}
+\f
+/* Helper function to create a <gdb:exception> object indicating that the
+ type of some value returned from a pretty-printer is invalid. */
+
+static SCM
+ppscm_make_pp_type_error_exception (const char *message, SCM object)
+{
+ char *msg = xstrprintf ("%s: ~S", message);
+ struct cleanup *cleanup = make_cleanup (xfree, msg);
+ SCM exception
+ = gdbscm_make_error (pp_type_error_symbol,
+ NULL /* func */, msg,
+ scm_list_1 (object), scm_list_1 (object));
+
+ do_cleanups (cleanup);
+
+ return exception;
+}
+
+/* Print MESSAGE as an exception (meaning it is controlled by
+ "guile print-stack").
+ Called from the printer code when the Scheme code returns an invalid type
+ for something. */
+
+static void
+ppscm_print_pp_type_error (const char *message, SCM object)
+{
+ SCM exception = ppscm_make_pp_type_error_exception (message, object);
+
+ gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
+}
+
+/* Helper function for find_pretty_printer which iterates over a list,
+ calls each function and inspects output. This will return a
+ <gdb:pretty-printer> object if one recognizes VALUE. If no printer is
+ found, it will return #f. On error, it will return a <gdb:exception>
+ object.
+
+ Note: This has to be efficient and careful.
+ We don't want to excessively slow down printing of values, but any kind of
+ random crud can appear in the pretty-printer list, and we can't crash
+ because of it. */
+
+static SCM
+ppscm_search_pp_list (SCM list, SCM value)
+{
+ SCM orig_list = list;
+
+ if (scm_is_null (list))
+ return SCM_BOOL_F;
+ if (gdbscm_is_false (scm_list_p (list))) /* scm_is_pair? */
+ {
+ return ppscm_make_pp_type_error_exception
+ (_("pretty-printer list is not a list"), list);
+ }
+
+ for ( ; scm_is_pair (list); list = scm_cdr (list))
+ {
+ SCM matcher = scm_car (list);
+ SCM worker;
+ pretty_printer_smob *pp_smob;
+ int rc;
+
+ if (!ppscm_is_pretty_printer (matcher))
+ {
+ return ppscm_make_pp_type_error_exception
+ (_("pretty-printer list contains non-pretty-printer object"),
+ matcher);
+ }
+
+ pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (matcher);
+
+ /* Skip if disabled. */
+ if (gdbscm_is_false (pp_smob->enabled))
+ continue;
+
+ if (!gdbscm_is_procedure (pp_smob->lookup))
+ {
+ return ppscm_make_pp_type_error_exception
+ (_("invalid lookup object in pretty-printer matcher"),
+ pp_smob->lookup);
+ }
+
+ worker = gdbscm_safe_call_2 (pp_smob->lookup, matcher,
+ value, gdbscm_memory_error_p);
+ if (!gdbscm_is_false (worker))
+ {
+ if (gdbscm_is_exception (worker))
+ return worker;
+ if (ppscm_is_pretty_printer_worker (worker))
+ return worker;
+ return ppscm_make_pp_type_error_exception
+ (_("invalid result from pretty-printer lookup"), worker);
+ }
+ }
+
+ if (!scm_is_null (list))
+ {
+ return ppscm_make_pp_type_error_exception
+ (_("pretty-printer list is not a list"), orig_list);
+ }
+
+ return SCM_BOOL_F;
+}
+
+/* Subroutine of find_pretty_printer to simplify it.
+ Look for a pretty-printer to print VALUE in all objfiles.
+ If there's an error an exception smob is returned.
+ The result is #f, if no pretty-printer was found.
+ Otherwise the result is the pretty-printer smob. */
+
+static SCM
+ppscm_find_pretty_printer_from_objfiles (SCM value)
+{
+ struct objfile *objfile;
+
+ ALL_OBJFILES (objfile)
+ {
+ objfile_smob *o_smob = ofscm_objfile_smob_from_objfile (objfile);
+ SCM pp = ppscm_search_pp_list (ofscm_objfile_smob_pretty_printers (o_smob),
+ value);
+
+ /* Note: This will return if pp is a <gdb:exception> object,
+ which is what we want. */
+ if (gdbscm_is_true (pp))
+ return pp;
+ }
+
+ return SCM_BOOL_F;
+}
+
+/* Subroutine of find_pretty_printer to simplify it.
+ Look for a pretty-printer to print VALUE in the current program space.
+ If there's an error an exception smob is returned.
+ The result is #f, if no pretty-printer was found.
+ Otherwise the result is the pretty-printer smob. */
+
+static SCM
+ppscm_find_pretty_printer_from_progspace (SCM value)
+{
+ return SCM_BOOL_F; /*TODO*/
+}
+
+/* Subroutine of find_pretty_printer to simplify it.
+ Look for a pretty-printer to print VALUE in the gdb module.
+ If there's an error a Scheme exception is returned.
+ The result is #f, if no pretty-printer was found.
+ Otherwise the result is the pretty-printer smob. */
+
+static SCM
+ppscm_find_pretty_printer_from_gdb (SCM value)
+{
+ SCM pp_list, pp;
+
+ /* Fetch the global pretty printer list. */
+ pp_list = scm_variable_ref (pretty_printer_list_var);
+ pp = ppscm_search_pp_list (pp_list, value);
+ return pp;
+}
+
+/* Find the pretty-printing constructor function for VALUE. If no
+ pretty-printer exists, return #f. If one exists, return the
+ gdb:pretty-printer smob that implements it. On error, an exception smob
+ is returned.
+
+ Note: In the end it may be better to call out to Scheme once, and then
+ do all of the lookup from Scheme. TBD. */
+
+static SCM
+ppscm_find_pretty_printer (SCM value)
+{
+ SCM pp;
+
+ /* Look at the pretty-printer list for each objfile
+ in the current program-space. */
+ pp = ppscm_find_pretty_printer_from_objfiles (value);
+ /* Note: This will return if function is a <gdb:exception> object,
+ which is what we want. */
+ if (gdbscm_is_true (pp))
+ return pp;
+
+ /* Look at the pretty-printer list for the current program-space. */
+ pp = ppscm_find_pretty_printer_from_progspace (value);
+ /* Note: This will return if function is a <gdb:exception> object,
+ which is what we want. */
+ if (gdbscm_is_true (pp))
+ return pp;
+
+ /* Look at the pretty-printer list in the gdb module. */
+ pp = ppscm_find_pretty_printer_from_gdb (value);
+ return pp;
+}
+
+/* Pretty-print a single value, via the PRINTER, which must be a
+ <gdb:pretty-printer-worker> object.
+ The caller is responsible for ensuring PRINTER is valid.
+ If the function returns a string, an SCM containing the string
+ is returned. If the function returns #f that means the pretty
+ printer returned #f as a value. Otherwise, if the function returns a
+ <gdb:value> object, *OUT_VALUE is set to the value and #t is returned.
+ It is an error if the printer returns #t.
+ On error, an exception smob is returned. */
+
+static SCM
+ppscm_pretty_print_one_value (SCM printer, struct value **out_value,
+ struct gdbarch *gdbarch,
+ const struct language_defn *language)
+{
+ volatile struct gdb_exception except;
+ SCM result = SCM_BOOL_F;
+
+ *out_value = NULL;
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ int rc;
+ pretty_printer_worker_smob *w_smob
+ = (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
+
+ result = gdbscm_safe_call_1 (w_smob->to_string, printer,
+ gdbscm_memory_error_p);
+ if (gdbscm_is_false (result))
+ ; /* Done. */
+ else if (scm_is_string (result)
+ || lsscm_is_lazy_string (result))
+ ; /* Done. */
+ else if (vlscm_is_value (result))
+ {
+ SCM except_scm;
+
+ *out_value
+ = vlscm_convert_value_from_scheme (FUNC_NAME, GDBSCM_ARG_NONE,
+ result, &except_scm,
+ gdbarch, language);
+ if (*out_value != NULL)
+ result = SCM_BOOL_T;
+ else
+ result = except_scm;
+ }
+ else if (gdbscm_is_exception (result))
+ ; /* Done. */
+ else
+ {
+ /* Invalid result from to-string. */
+ result = ppscm_make_pp_type_error_exception
+ (_("invalid result from pretty-printer to-string"), result);
+ }
+ }
+
+ return result;
+}
+
+/* Return the display hint for PRINTER as a Scheme object.
+ The caller is responsible for ensuring PRINTER is a
+ <gdb:pretty-printer-worker> object. */
+
+static SCM
+ppscm_get_display_hint_scm (SCM printer)
+{
+ pretty_printer_worker_smob *w_smob
+ = (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
+
+ return w_smob->display_hint;
+}
+
+/* Return the display hint for the pretty-printer PRINTER.
+ The caller is responsible for ensuring PRINTER is a
+ <gdb:pretty-printer-worker> object.
+ Returns the display hint or #f if the hint is not a string. */
+
+static enum display_hint
+ppscm_get_display_hint_enum (SCM printer)
+{
+ SCM hint = ppscm_get_display_hint_scm (printer);
+
+ if (gdbscm_is_false (hint))
+ return HINT_NONE;
+ if (scm_is_string (hint))
+ {
+ if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_array_string)))
+ return HINT_STRING;
+ if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_map_string)))
+ return HINT_STRING;
+ if (gdbscm_is_true (scm_string_equal_p (hint, ppscm_string_string)))
+ return HINT_STRING;
+ return HINT_ERROR;
+ }
+ return HINT_ERROR;
+}
+
+/* A wrapper for gdbscm_print_gdb_exception that ignores memory errors.
+ EXCEPTION is a <gdb:exception> object. */
+
+static void
+ppscm_print_exception_unless_memory_error (SCM exception,
+ struct ui_file *stream)
+{
+ if (gdbscm_memory_error_p (gdbscm_exception_key (exception)))
+ {
+ char *msg = gdbscm_exception_message_to_string (exception);
+ struct cleanup *cleanup = make_cleanup (xfree, msg);
+
+ /* This "shouldn't happen", but play it safe. */
+ if (msg == NULL || *msg == '\0')
+ fprintf_filtered (stream, _("<error reading variable>"));
+ else
+ {
+ /* Remove the trailing newline. We could instead call a special
+ routine for printing memory error messages, but this is easy
+ enough for now. */
+ size_t len = strlen (msg);
+
+ if (msg[len - 1] == '\n')
+ msg[len - 1] = '\0';
+ fprintf_filtered (stream, _("<error reading variable: %s>"), msg);
+ }
+
+ do_cleanups (cleanup);
+ }
+ else
+ gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
+}
+
+/* Helper for gdbscm_apply_val_pretty_printer which calls to_string and
+ formats the result. */
+
+static enum string_repr_result
+ppscm_print_string_repr (SCM printer, enum display_hint hint,
+ struct ui_file *stream, int recurse,
+ const struct value_print_options *options,
+ struct gdbarch *gdbarch,
+ const struct language_defn *language)
+{
+ struct value *replacement = NULL;
+ SCM str_scm;
+ enum string_repr_result result = STRING_REPR_ERROR;
+
+ str_scm = ppscm_pretty_print_one_value (printer, &replacement,
+ gdbarch, language);
+ if (gdbscm_is_false (str_scm))
+ {
+ result = STRING_REPR_NONE;
+ }
+ else if (scm_is_eq (str_scm, SCM_BOOL_T))
+ {
+ struct value_print_options opts = *options;
+
+ gdb_assert (replacement != NULL);
+ opts.addressprint = 0;
+ common_val_print (replacement, stream, recurse, &opts, language);
+ result = STRING_REPR_OK;
+ }
+ else if (scm_is_string (str_scm))
+ {
+ struct cleanup *cleanup;
+ size_t length;
+ char *string
+ = gdbscm_scm_to_string (str_scm, &length,
+ target_charset (gdbarch), 0 /*!strict*/, NULL);
+
+ cleanup = make_cleanup (xfree, string);
+ if (hint == HINT_STRING)
+ {
+ struct type *type = builtin_type (gdbarch)->builtin_char;
+
+ LA_PRINT_STRING (stream, type, (gdb_byte *) string,
+ length, NULL, 0, options);
+ }
+ else
+ {
+ /* Alas scm_to_stringn doesn't nul-terminate the string if we
+ ask for the length. */
+ size_t i;
+
+ for (i = 0; i < length; ++i)
+ {
+ if (string[i] == '\0')
+ fputs_filtered ("\\000", stream);
+ else
+ fputc_filtered (string[i], stream);
+ }
+ }
+ result = STRING_REPR_OK;
+ do_cleanups (cleanup);
+ }
+ else if (lsscm_is_lazy_string (str_scm))
+ {
+ struct value_print_options local_opts = *options;
+
+ local_opts.addressprint = 0;
+ lsscm_val_print_lazy_string (str_scm, stream, &local_opts);
+ result = STRING_REPR_OK;
+ }
+ else
+ {
+ gdb_assert (gdbscm_is_exception (str_scm));
+ ppscm_print_exception_unless_memory_error (str_scm, stream);
+ result = STRING_REPR_ERROR;
+ }
+
+ return result;
+}
+
+/* Helper for gdbscm_apply_val_pretty_printer that formats children of the
+ printer, if any exist.
+ The caller is responsible for ensuring PRINTER is a printer smob.
+ If PRINTED_NOTHING is true, then nothing has been printed by to_string,
+ and format output accordingly. */
+
+static void
+ppscm_print_children (SCM printer, enum display_hint hint,
+ struct ui_file *stream, int recurse,
+ const struct value_print_options *options,
+ struct gdbarch *gdbarch,
+ const struct language_defn *language,
+ int printed_nothing)
+{
+ pretty_printer_worker_smob *w_smob
+ = (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
+ int is_map, is_array, done_flag, pretty;
+ unsigned int i;
+ SCM children, status;
+ SCM iter = SCM_BOOL_F; /* -Wall */
+ struct cleanup *cleanups;
+
+ if (gdbscm_is_false (w_smob->children))
+ return;
+ if (!gdbscm_is_procedure (w_smob->children))
+ {
+ ppscm_print_pp_type_error
+ (_("pretty-printer \"children\" object is not a procedure or #f"),
+ w_smob->children);
+ return;
+ }
+
+ cleanups = make_cleanup (null_cleanup, NULL);
+
+ /* If we are printing a map or an array, we want special formatting. */
+ is_map = hint == HINT_MAP;
+ is_array = hint == HINT_ARRAY;
+
+ children = gdbscm_safe_call_1 (w_smob->children, printer,
+ gdbscm_memory_error_p);
+ if (gdbscm_is_exception (children))
+ {
+ ppscm_print_exception_unless_memory_error (children, stream);
+ goto done;
+ }
+ /* We combine two steps here: get children, make an iterator out of them.
+ This simplifies things because there's no language means of creating
+ iterators, and it's the printer object that knows how it will want its
+ children iterated over. */
+ if (!itscm_is_iterator (children))
+ {
+ ppscm_print_pp_type_error
+ (_("result of pretty-printer \"children\" procedure is not"
+ " a <gdb:iterator> object"), children);
+ goto done;
+ }
+ iter = children;
+
+ /* Use the prettyformat_arrays option if we are printing an array,
+ and the pretty option otherwise. */
+ if (is_array)
+ pretty = options->prettyformat_arrays;
+ else
+ {
+ if (options->prettyformat == Val_prettyformat)
+ pretty = 1;
+ else
+ pretty = options->prettyformat_structs;
+ }
+
+ done_flag = 0;
+ for (i = 0; i < options->print_max; ++i)
+ {
+ int rc;
+ SCM scm_name, v_scm;
+ char *name;
+ SCM item = itscm_safe_call_next_x (iter, gdbscm_memory_error_p);
+ struct cleanup *inner_cleanup = make_cleanup (null_cleanup, NULL);
+
+ if (gdbscm_is_exception (item))
+ {
+ ppscm_print_exception_unless_memory_error (item, stream);
+ break;
+ }
+ if (itscm_is_end_of_iteration (item))
+ {
+ /* Set a flag so we can know whether we printed all the
+ available elements. */
+ done_flag = 1;
+ break;
+ }
+
+ if (! scm_is_pair (item))
+ {
+ ppscm_print_pp_type_error
+ (_("result of pretty-printer children iterator is not a pair"
+ " or (end-of-iteration)"),
+ item);
+ continue;
+ }
+ scm_name = scm_car (item);
+ v_scm = scm_cdr (item);
+ if (!scm_is_string (scm_name))
+ {
+ ppscm_print_pp_type_error
+ (_("first element of pretty-printer children iterator is not"
+ " a string"), item);
+ continue;
+ }
+ name = gdbscm_scm_to_c_string (scm_name);
+ make_cleanup (xfree, name);
+
+ /* Print initial "{". For other elements, there are three cases:
+ 1. Maps. Print a "," after each value element.
+ 2. Arrays. Always print a ",".
+ 3. Other. Always print a ",". */
+ if (i == 0)
+ {
+ if (printed_nothing)
+ fputs_filtered ("{", stream);
+ else
+ fputs_filtered (" = {", stream);
+ }
+
+ else if (! is_map || i % 2 == 0)
+ fputs_filtered (pretty ? "," : ", ", stream);
+
+ /* In summary mode, we just want to print "= {...}" if there is
+ a value. */
+ if (options->summary)
+ {
+ /* This increment tricks the post-loop logic to print what
+ we want. */
+ ++i;
+ /* Likewise. */
+ pretty = 0;
+ break;
+ }
+
+ if (! is_map || i % 2 == 0)
+ {
+ if (pretty)
+ {
+ fputs_filtered ("\n", stream);
+ print_spaces_filtered (2 + 2 * recurse, stream);
+ }
+ else
+ wrap_here (n_spaces (2 + 2 *recurse));
+ }
+
+ if (is_map && i % 2 == 0)
+ fputs_filtered ("[", stream);
+ else if (is_array)
+ {
+ /* We print the index, not whatever the child method
+ returned as the name. */
+ if (options->print_array_indexes)
+ fprintf_filtered (stream, "[%d] = ", i);
+ }
+ else if (! is_map)
+ {
+ fputs_filtered (name, stream);
+ fputs_filtered (" = ", stream);
+ }
+
+ if (lsscm_is_lazy_string (v_scm))
+ {
+ struct value_print_options local_opts = *options;
+
+ local_opts.addressprint = 0;
+ lsscm_val_print_lazy_string (v_scm, stream, &local_opts);
+ }
+ else if (scm_is_string (v_scm))
+ {
+ char *output = gdbscm_scm_to_c_string (v_scm);
+
+ fputs_filtered (output, stream);
+ xfree (output);
+ }
+ else
+ {
+ SCM except_scm;
+ struct value *value
+ = vlscm_convert_value_from_scheme (FUNC_NAME, GDBSCM_ARG_NONE,
+ v_scm, &except_scm,
+ gdbarch, language);
+
+ if (value == NULL)
+ {
+ ppscm_print_exception_unless_memory_error (except_scm, stream);
+ break;
+ }
+ common_val_print (value, stream, recurse + 1, options, language);
+ }
+
+ if (is_map && i % 2 == 0)
+ fputs_filtered ("] = ", stream);
+
+ do_cleanups (inner_cleanup);
+ }
+
+ if (i)
+ {
+ if (!done_flag)
+ {
+ if (pretty)
+ {
+ fputs_filtered ("\n", stream);
+ print_spaces_filtered (2 + 2 * recurse, stream);
+ }
+ fputs_filtered ("...", stream);
+ }
+ if (pretty)
+ {
+ fputs_filtered ("\n", stream);
+ print_spaces_filtered (2 * recurse, stream);
+ }
+ fputs_filtered ("}", stream);
+ }
+
+ done:
+ do_cleanups (cleanups);
+
+ /* Play it safe, make sure ITER doesn't get GC'd. */
+ scm_remember_upto_here_1 (iter);
+}
+
+/* This is the extension_language_ops.apply_val_pretty_printer "method". */
+
+enum ext_lang_rc
+gdbscm_apply_val_pretty_printer (const struct extension_language_defn *extlang,
+ 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)
+{
+ struct gdbarch *gdbarch = get_type_arch (type);
+ SCM exception = SCM_BOOL_F;
+ SCM printer = SCM_BOOL_F;
+ SCM val_obj = SCM_BOOL_F;
+ struct value *value;
+ enum display_hint hint;
+ struct cleanup *cleanups;
+ int result = EXT_LANG_RC_NOP;
+ enum string_repr_result print_result;
+
+ /* No pretty-printer support for unavailable values. */
+ if (!value_bytes_available (val, embedded_offset, TYPE_LENGTH (type)))
+ return EXT_LANG_RC_NOP;
+
+ if (!gdb_scheme_initialized)
+ return EXT_LANG_RC_NOP;
+
+ cleanups = make_cleanup (null_cleanup, NULL);
+
+ /* Instantiate the printer. */
+ if (valaddr)
+ valaddr += embedded_offset;
+ value = value_from_contents_and_address (type, valaddr,
+ address + embedded_offset);
+
+ set_value_component_location (value, val);
+ /* set_value_component_location resets the address, so we may
+ need to set it again. */
+ if (VALUE_LVAL (value) != lval_internalvar
+ && VALUE_LVAL (value) != lval_internalvar_component
+ && VALUE_LVAL (value) != lval_computed)
+ set_value_address (value, address + embedded_offset);
+
+ val_obj = vlscm_scm_from_value (value);
+ if (gdbscm_is_exception (val_obj))
+ {
+ exception = val_obj;
+ result = EXT_LANG_RC_ERROR;
+ goto done;
+ }
+
+ printer = ppscm_find_pretty_printer (val_obj);
+
+ if (gdbscm_is_exception (printer))
+ {
+ exception = printer;
+ result = EXT_LANG_RC_ERROR;
+ goto done;
+ }
+ if (gdbscm_is_false (printer))
+ {
+ result = EXT_LANG_RC_NOP;
+ goto done;
+ }
+ gdb_assert (ppscm_is_pretty_printer_worker (printer));
+
+ /* If we are printing a map, we want some special formatting. */
+ hint = ppscm_get_display_hint_enum (printer);
+ if (hint == HINT_ERROR)
+ {
+ /* Print the error as an exception for consistency. */
+ SCM hint_scm = ppscm_get_display_hint_scm (printer);
+
+ ppscm_print_pp_type_error ("Invalid display hint", hint_scm);
+ /* Fall through. A bad hint doesn't stop pretty-printing. */
+ hint = HINT_NONE;
+ }
+
+ /* Print the section. */
+ print_result = ppscm_print_string_repr (printer, hint, stream, recurse,
+ options, gdbarch, language);
+ if (print_result != STRING_REPR_ERROR)
+ {
+ ppscm_print_children (printer, hint, stream, recurse, options,
+ gdbarch, language,
+ print_result == STRING_REPR_NONE);
+ }
+
+ result = EXT_LANG_RC_OK;
+
+ done:
+ if (gdbscm_is_exception (exception))
+ ppscm_print_exception_unless_memory_error (exception, stream);
+ do_cleanups (cleanups);
+ return result;
+}
+\f
+/* Initialize the Scheme pretty-printer code. */
+
+static const scheme_function pretty_printer_functions[] =
+{
+ { "make-pretty-printer", 2, 0, 0, gdbscm_make_pretty_printer,
+ "\
+Create a <gdb:pretty-printer> object.\n\
+\n\
+ Arguments: name lookup\n\
+ name: a string naming the matcher\n\
+ lookup: a procedure:\n\
+ (pretty-printer <gdb:value>) -> <gdb:pretty-printer-worker> | #f." },
+
+ { "pretty-printer?", 1, 0, 0, gdbscm_pretty_printer_p,
+ "\
+Return #t if the object is a <gdb:pretty-printer> object." },
+
+ { "pretty-printer-enabled?", 1, 0, 0, gdbscm_pretty_printer_enabled_p,
+ "\
+Return #t if the pretty-printer is enabled." },
+
+ { "set-pretty-printer-enabled!", 2, 0, 0,
+ gdbscm_set_pretty_printer_enabled_x,
+ "\
+Set the enabled flag of the pretty-printer.\n\
+Returns \"unspecified\"." },
+
+ { "make-pretty-printer-worker", 3, 0, 0, gdbscm_make_pretty_printer_worker,
+ "\
+Create a <gdb:pretty-printer-worker> object.\n\
+\n\
+ Arguments: display-hint to-string children\n\
+ display-hint: either #f or one of \"array\", \"map\", or \"string\"\n\
+ to-string: a procedure:\n\
+ (pretty-printer) -> string | #f | <gdb:value>\n\
+ children: either #f or a procedure:\n\
+ (pretty-printer) -> <gdb:iterator>" },
+
+ { "pretty-printer-worker?", 1, 0, 0, gdbscm_pretty_printer_worker_p,
+ "\
+Return #t if the object is a <gdb:pretty-printer-worker> object." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_pretty_printers (void)
+{
+ pretty_printer_smob_tag
+ = gdbscm_make_smob_type (pretty_printer_smob_name,
+ sizeof (pretty_printer_smob));
+ scm_set_smob_mark (pretty_printer_smob_tag,
+ ppscm_mark_pretty_printer_smob);
+ scm_set_smob_print (pretty_printer_smob_tag,
+ ppscm_print_pretty_printer_smob);
+
+ pretty_printer_worker_smob_tag
+ = gdbscm_make_smob_type (pretty_printer_worker_smob_name,
+ sizeof (pretty_printer_worker_smob));
+ scm_set_smob_mark (pretty_printer_worker_smob_tag,
+ ppscm_mark_pretty_printer_worker_smob);
+ scm_set_smob_print (pretty_printer_worker_smob_tag,
+ ppscm_print_pretty_printer_worker_smob);
+
+ gdbscm_define_functions (pretty_printer_functions, 1);
+
+ scm_c_define (pretty_printer_list_name, SCM_EOL);
+
+ pretty_printer_list_var
+ = scm_c_private_variable (gdbscm_module_name,
+ pretty_printer_list_name);
+ gdb_assert (!gdbscm_is_false (pretty_printer_list_var));
+
+ pp_type_error_symbol = scm_from_latin1_symbol ("gdb:pp-type-error");
+
+ ppscm_map_string = scm_from_latin1_string ("map");
+ ppscm_array_string = scm_from_latin1_string ("array");
+ ppscm_string_string = scm_from_latin1_string ("string");
+}
--- /dev/null
+/* GDB/Scheme support for safe calls into the Guile interpreter.
+
+ Copyright (C) 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 "filenames.h"
+#include "gdb_assert.h"
+#include "guile-internal.h"
+
+/* Struct to marshall args to scscm_safe_call_body. */
+
+struct c_data
+{
+ void *(*func) (void *);
+ void *data;
+ /* An error message or NULL for success. */
+ void *result;
+};
+
+/* Struct to marshall args through gdbscm_with_catch. */
+
+struct with_catch_data
+{
+ scm_t_catch_body func;
+ void *data;
+ scm_t_catch_handler unwind_handler;
+ scm_t_catch_handler pre_unwind_handler;
+
+ /* If EXCP_MATCHER is non-NULL, it is an excp_matcher_func function.
+ If the exception is recognized by it, the exception is recorded as is,
+ without wrapping it in gdb:with-stack. */
+ excp_matcher_func *excp_matcher;
+
+ SCM stack;
+ SCM catch_result;
+};
+
+/* The "body" argument to scm_i_with_continuation_barrier.
+ Invoke the user-supplied function. */
+
+static SCM
+scscm_safe_call_body (void *d)
+{
+ struct c_data *data = (struct c_data *) d;
+
+ data->result = data->func (data->data);
+
+ return SCM_UNSPECIFIED;
+}
+
+/* A "pre-unwind handler" to scm_c_catch that prints the exception
+ according to "set guile print-stack". */
+
+static SCM
+scscm_printing_pre_unwind_handler (void *data, SCM key, SCM args)
+{
+ SCM stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
+
+ gdbscm_print_exception_with_stack (SCM_BOOL_F, stack, key, args);
+
+ return SCM_UNSPECIFIED;
+}
+
+/* A no-op unwind handler. */
+
+static SCM
+scscm_nop_unwind_handler (void *data, SCM key, SCM args)
+{
+ return SCM_UNSPECIFIED;
+}
+
+/* The "pre-unwind handler" to scm_c_catch that records the exception
+ for possible later printing. We do this in the pre-unwind handler because
+ we want the stack to include point where the exception occurred.
+
+ If DATA is non-NULL, it is an excp_matcher_func function.
+ If the exception is recognized by it, the exception is recorded as is,
+ without wrapping it in gdb:with-stack. */
+
+static SCM
+scscm_recording_pre_unwind_handler (void *datap, SCM key, SCM args)
+{
+ struct with_catch_data *data = datap;
+ excp_matcher_func *matcher = data->excp_matcher;
+
+ if (matcher != NULL && matcher (key))
+ return SCM_UNSPECIFIED;
+
+ /* There's no need to record the whole stack if we're not going to print it.
+ However, convention is to still print the stack frame in which the
+ exception occurred, even if we're not going to print a full backtrace.
+ For now, keep it simple. */
+
+ data->stack = scm_make_stack (SCM_BOOL_T, scm_list_1 (scm_from_int (2)));
+
+ /* IWBN if we could return the <gdb:exception> here and skip the unwind
+ handler, but it doesn't work that way. If we want to return a
+ <gdb:exception> object from the catch it needs to come from the unwind
+ handler. So what we do is save the stack for later use by the unwind
+ handler. */
+
+ return SCM_UNSPECIFIED;
+}
+
+/* Part two of the recording unwind handler.
+ Here we take the stack saved from the pre-unwind handler and create
+ the <gdb:exception> object. */
+
+static SCM
+scscm_recording_unwind_handler (void *datap, SCM key, SCM args)
+{
+ struct with_catch_data *data = datap;
+
+ /* We need to record the stack in the exception since we're about to
+ throw and lose the location that got the exception. We do this by
+ wrapping the exception + stack in a new exception. */
+
+ if (gdbscm_is_true (data->stack))
+ return gdbscm_make_exception_with_stack (key, args, data->stack);
+
+ return gdbscm_make_exception (key, args);
+}
+
+/* Ugh. :-(
+ Guile doesn't export scm_i_with_continuation_barrier which is exactly
+ what we need. To cope, have our own wrapper around scm_c_catch and
+ pass this as the "body" argument to scm_c_with_continuation_barrier.
+ Darn darn darn. */
+
+static void *
+gdbscm_with_catch (void *data)
+{
+ struct with_catch_data *d = data;
+
+ d->catch_result
+ = scm_c_catch (SCM_BOOL_T,
+ d->func, d->data,
+ d->unwind_handler, d,
+ d->pre_unwind_handler, d);
+
+ return NULL;
+}
+
+/* A wrapper around scm_with_guile that prints backtraces and exceptions
+ according to "set guile print-stack".
+ The result if NULL if no exception occurred, otherwise it is a statically
+ allocated error message (caller must *not* free). */
+
+void *
+gdbscm_with_guile (void *(*func) (void *), void *data)
+{
+ struct c_data c_data;
+ struct with_catch_data catch_data;
+
+ c_data.func = func;
+ c_data.data = data;
+ /* Set this now in case an exception is thrown. */
+ c_data.result = _("Error while executing Scheme code.");
+
+ catch_data.func = scscm_safe_call_body;
+ catch_data.data = &c_data;
+ catch_data.unwind_handler = scscm_nop_unwind_handler;
+ catch_data.pre_unwind_handler = scscm_printing_pre_unwind_handler;
+ catch_data.excp_matcher = NULL;
+ catch_data.stack = SCM_BOOL_F;
+ catch_data.catch_result = SCM_UNSPECIFIED;
+
+ scm_with_guile (gdbscm_with_catch, &catch_data);
+
+ return c_data.result;
+}
+
+/* Another wrapper of scm_with_guile for use by the safe call/apply routines
+ in this file, as well as for general purpose calling other functions safely.
+ For these we want to record the exception, but leave the possible printing
+ of it to later. */
+
+SCM
+gdbscm_call_guile (SCM (*func) (void *), void *data,
+ excp_matcher_func *ok_excps)
+{
+ struct with_catch_data catch_data;
+
+ catch_data.func = func;
+ catch_data.data = data;
+ catch_data.unwind_handler = scscm_recording_unwind_handler;
+ catch_data.pre_unwind_handler = scscm_recording_pre_unwind_handler;
+ catch_data.excp_matcher = ok_excps;
+ catch_data.stack = SCM_BOOL_F;
+ catch_data.catch_result = SCM_UNSPECIFIED;
+
+#if 0
+ scm_c_with_continuation_barrier (gdbscm_with_catch, &catch_data);
+#else
+ scm_with_guile (gdbscm_with_catch, &catch_data);
+#endif
+
+ return catch_data.catch_result;
+}
+\f
+/* Utilities to safely call Scheme code, catching all exceptions, and
+ preventing continuation capture.
+ The result is the result of calling the function, or if an exception occurs
+ then the result is a <gdb:exception> smob, which can be tested for with
+ gdbscm_is_exception. */
+
+/* Helper for gdbscm_safe_call_0. */
+
+static SCM
+scscm_call_0_body (void *argsp)
+{
+ SCM *args = argsp;
+
+ return scm_call_0 (args[0]);
+}
+
+SCM
+gdbscm_safe_call_0 (SCM proc, excp_matcher_func *ok_excps)
+{
+ SCM args[] = { proc };
+
+ return gdbscm_call_guile (scscm_call_0_body, args, ok_excps);
+}
+
+/* Helper for gdbscm_safe_call_1. */
+
+static SCM
+scscm_call_1_body (void *argsp)
+{
+ SCM *args = argsp;
+
+ return scm_call_1 (args[0], args[1]);
+}
+
+SCM
+gdbscm_safe_call_1 (SCM proc, SCM arg0, excp_matcher_func *ok_excps)
+{
+ SCM args[] = { proc, arg0 };
+
+ return gdbscm_call_guile (scscm_call_1_body, args, ok_excps);
+}
+
+/* Helper for gdbscm_safe_call_2. */
+
+static SCM
+scscm_call_2_body (void *argsp)
+{
+ SCM *args = argsp;
+
+ return scm_call_2 (args[0], args[1], args[2]);
+}
+
+SCM
+gdbscm_safe_call_2 (SCM proc, SCM arg0, SCM arg1, excp_matcher_func *ok_excps)
+{
+ SCM args[] = { proc, arg0, arg1 };
+
+ return gdbscm_call_guile (scscm_call_2_body, args, ok_excps);
+}
+
+/* Helper for gdbscm_safe_call_3. */
+
+static SCM
+scscm_call_3_body (void *argsp)
+{
+ SCM *args = argsp;
+
+ return scm_call_3 (args[0], args[1], args[2], args[3]);
+}
+
+SCM
+gdbscm_safe_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3,
+ excp_matcher_func *ok_excps)
+{
+ SCM args[] = { proc, arg1, arg2, arg3 };
+
+ return gdbscm_call_guile (scscm_call_3_body, args, ok_excps);
+}
+
+/* Helper for gdbscm_safe_call_4. */
+
+static SCM
+scscm_call_4_body (void *argsp)
+{
+ SCM *args = argsp;
+
+ return scm_call_4 (args[0], args[1], args[2], args[3], args[4]);
+}
+
+SCM
+gdbscm_safe_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4,
+ excp_matcher_func *ok_excps)
+{
+ SCM args[] = { proc, arg1, arg2, arg3, arg4 };
+
+ return gdbscm_call_guile (scscm_call_4_body, args, ok_excps);
+}
+
+/* Helper for gdbscm_safe_apply_1. */
+
+static SCM
+scscm_apply_1_body (void *argsp)
+{
+ SCM *args = argsp;
+
+ return scm_apply_1 (args[0], args[1], args[2]);
+}
+
+SCM
+gdbscm_safe_apply_1 (SCM proc, SCM arg0, SCM rest, excp_matcher_func *ok_excps)
+{
+ SCM args[] = { proc, arg0, rest };
+
+ return gdbscm_call_guile (scscm_apply_1_body, args, ok_excps);
+}
+\f
+/* Utilities to call Scheme code, not catching exceptions, and
+ not preventing continuation capture.
+ The result is the result of calling the function.
+ If an exception occurs then Guile is left to handle the exception,
+ unwinding the stack as appropriate.
+
+ USE THESE WITH CARE.
+ Typically these are called from functions that implement Scheme procedures,
+ and we don't want to catch the exception; otherwise it will get printed
+ twice: once when first caught and once if it ends up being rethrown and the
+ rethrow reaches the top repl, which will confuse the user.
+
+ While these calls just pass the call off to the corresponding Guile
+ procedure, all such calls are routed through these ones to:
+ a) provide a place to put hooks or whatnot in if we need to,
+ b) add "unsafe" to the name to alert the reader. */
+
+SCM
+gdbscm_unsafe_call_1 (SCM proc, SCM arg0)
+{
+ return scm_call_1 (proc, arg0);
+}
+\f
+/* Utilities for safely evaluating a Scheme expression string. */
+
+struct eval_scheme_string_data
+{
+ const char *string;
+ int display_result;
+};
+
+/* Wrapper to eval a C string in the Guile interpreter.
+ This is passed to scm_with_guile. */
+
+static void *
+scscm_eval_scheme_string (void *datap)
+{
+ struct eval_scheme_string_data *data = datap;
+ SCM result = scm_c_eval_string (data->string);
+
+ if (data->display_result && !scm_is_eq (result, SCM_UNSPECIFIED))
+ {
+ SCM port = scm_current_output_port ();
+
+ scm_write (result, port);
+ scm_newline (port);
+ }
+
+ /* If we get here the eval succeeded. */
+ return NULL;
+}
+
+/* Evaluate EXPR in the Guile interpreter, catching all exceptions
+ and preventing continuation capture.
+ The result is NULL if no exception occurred. Otherwise, the exception is
+ printed according to "set guile print-stack" and the result is an error
+ message allocated with malloc, caller must free. */
+
+char *
+gdbscm_safe_eval_string (const char *string, int display_result)
+{
+ struct eval_scheme_string_data data = { string, display_result };
+ void *result;
+
+ result = gdbscm_with_guile (scscm_eval_scheme_string, (void *) &data);
+
+ if (result != NULL)
+ return xstrdup (result);
+ return NULL;
+}
+\f
+/* Utilities for safely loading Scheme scripts. */
+
+/* Helper function for gdbscm_safe_source_scheme_script. */
+
+static void *
+scscm_source_scheme_script (void *data)
+{
+ const char *filename = data;
+
+ /* The Guile docs don't specify what the result is.
+ Maybe it's SCM_UNSPECIFIED, but the docs should specify that. :-) */
+ scm_c_primitive_load_path (filename);
+
+ /* If we get here the load succeeded. */
+ return NULL;
+}
+
+/* Try to load a script, catching all exceptions,
+ and preventing continuation capture.
+ The result is NULL if the load succeeded. Otherwise, the exception is
+ printed according to "set guile print-stack" and the result is an error
+ message allocated with malloc, caller must free. */
+
+char *
+gdbscm_safe_source_script (const char *filename)
+{
+ /* scm_c_primitive_load_path only looks in %load-path for files with
+ relative paths. An alternative could be to temporarily add "." to
+ %load-path, but we don't want %load-path to be searched. At least not
+ by default. This function is invoked by the "source" GDB command which
+ already has its own path search support. */
+ char *abs_filename = NULL;
+ void *result;
+
+ if (!IS_ABSOLUTE_PATH (filename))
+ {
+ abs_filename = gdb_realpath (filename);
+ filename = abs_filename;
+ }
+
+ result = gdbscm_with_guile (scscm_source_scheme_script,
+ (void *) filename);
+
+ xfree (abs_filename);
+ if (result != NULL)
+ return xstrdup (result);
+ return NULL;
+}
+\f
+/* Utility for entering an interactive Guile repl. */
+
+void
+gdbscm_enter_repl (void)
+{
+ /* It's unfortunate to have to resort to something like this, but
+ scm_shell doesn't return. :-( I found this code on guile-user@. */
+ gdbscm_safe_call_1 (scm_c_public_ref ("system repl repl", "start-repl"),
+ scm_from_latin1_symbol ("scheme"), NULL);
+}
--- /dev/null
+/* GDB/Scheme charset interface.
+
+ Copyright (C) 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 <stdarg.h>
+#include "charset.h"
+#include "guile-internal.h"
+
+/* Convert a C (latin1) string to an SCM string.
+ "latin1" is chosen because Guile won't throw an exception. */
+
+SCM
+gdbscm_scm_from_c_string (const char *string)
+{
+ return scm_from_latin1_string (string);
+}
+
+/* Convert an SCM string to a C (latin1) string.
+ "latin1" is chosen because Guile won't throw an exception.
+ Space for the result is allocated with malloc, caller must free.
+ It is an error to call this if STRING is not a string. */
+
+char *
+gdbscm_scm_to_c_string (SCM string)
+{
+ return scm_to_latin1_string (string);
+}
+
+/* Use printf to construct a Scheme string. */
+
+SCM
+gdbscm_scm_from_printf (const char *format, ...)
+{
+ va_list args;
+ char *string;
+ SCM result;
+
+ va_start (args, format);
+ string = xstrvprintf (format, args);
+ va_end (args);
+ result = scm_from_latin1_string (string);
+ xfree (string);
+
+ return result;
+}
+
+/* Struct to pass data from gdbscm_scm_to_string to
+ gdbscm_call_scm_to_stringn. */
+
+struct scm_to_stringn_data
+{
+ SCM string;
+ size_t *lenp;
+ const char *charset;
+ int conversion_kind;
+ char *result;
+};
+
+/* Helper for gdbscm_scm_to_string to call scm_to_stringn
+ from within scm_c_catch. */
+
+static SCM
+gdbscm_call_scm_to_stringn (void *datap)
+{
+ struct scm_to_stringn_data *data = datap;
+
+ data->result = scm_to_stringn (data->string, data->lenp, data->charset,
+ data->conversion_kind);
+ return SCM_BOOL_F;
+}
+
+/* Convert an SCM string to a string in charset CHARSET.
+ This function is guaranteed to not throw an exception.
+ If STRICT is non-zero, and there's a conversion error, then a
+ <gdb:exception> object is stored in *EXCEPT_SCMP, and NULL is returned.
+ If STRICT is zero, then escape sequences are used for characters that
+ can't be converted, and EXCEPT_SCMP may be passed as NULL.
+ Space for the result is allocated with malloc, caller must free.
+ It is an error to call this if STRING is not a string. */
+
+char *
+gdbscm_scm_to_string (SCM string, size_t *lenp,
+ const char *charset, int strict, SCM *except_scmp)
+{
+ struct scm_to_stringn_data data;
+ SCM scm_result;
+
+ data.string = string;
+ data.lenp = lenp;
+ data.charset = charset;
+ data.conversion_kind = (strict
+ ? SCM_FAILED_CONVERSION_ERROR
+ : SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
+ data.result = NULL;
+
+ scm_result = gdbscm_call_guile (gdbscm_call_scm_to_stringn, &data, NULL);
+
+ if (gdbscm_is_false (scm_result))
+ {
+ gdb_assert (data.result != NULL);
+ return data.result;
+ }
+ gdb_assert (gdbscm_is_exception (scm_result));
+ *except_scmp = scm_result;
+ return NULL;
+}
+
+/* Struct to pass data from gdbscm_scm_from_string to
+ gdbscm_call_scm_from_stringn. */
+
+struct scm_from_stringn_data
+{
+ const char *string;
+ size_t len;
+ const char *charset;
+ int conversion_kind;
+ SCM result;
+};
+
+/* Helper for gdbscm_scm_from_string to call scm_from_stringn
+ from within scm_c_catch. */
+
+static SCM
+gdbscm_call_scm_from_stringn (void *datap)
+{
+ struct scm_from_stringn_data *data = datap;
+
+ data->result = scm_from_stringn (data->string, data->len, data->charset,
+ data->conversion_kind);
+ return SCM_BOOL_F;
+}
+
+/* Convert STRING to a Scheme string in charset CHARSET.
+ This function is guaranteed to not throw an exception.
+ If STRICT is non-zero, and there's a conversion error, then a
+ <gdb:exception> object is returned.
+ If STRICT is zero, then question marks are used for characters that
+ can't be converted (limitation of underlying Guile conversion support). */
+
+SCM
+gdbscm_scm_from_string (const char *string, size_t len,
+ const char *charset, int strict)
+{
+ struct scm_from_stringn_data data;
+ SCM scm_result;
+
+ data.string = string;
+ data.len = len;
+ data.charset = charset;
+ /* The use of SCM_FAILED_CONVERSION_QUESTION_MARK is specified by Guile. */
+ data.conversion_kind = (strict
+ ? SCM_FAILED_CONVERSION_ERROR
+ : SCM_FAILED_CONVERSION_QUESTION_MARK);
+ data.result = SCM_UNDEFINED;
+
+ scm_result = gdbscm_call_guile (gdbscm_call_scm_from_stringn, &data, NULL);
+
+ if (gdbscm_is_false (scm_result))
+ {
+ gdb_assert (!SCM_UNBNDP (data.result));
+ return data.result;
+ }
+ gdb_assert (gdbscm_is_exception (scm_result));
+ return scm_result;
+}
+
+/* Convert an SCM string to a target string.
+ This function will thrown a conversion error if there's a problem.
+ Space for the result is allocated with malloc, caller must free.
+ It is an error to call this if STRING is not a string. */
+
+char *
+gdbscm_scm_to_target_string_unsafe (SCM string, size_t *lenp,
+ struct gdbarch *gdbarch)
+{
+ return scm_to_stringn (string, lenp, target_charset (gdbarch),
+ SCM_FAILED_CONVERSION_ERROR);
+}
+
+/* (string->argv string) -> list
+ Return list of strings split up according to GDB's argv parsing rules.
+ This is useful when writing GDB commands in Scheme. */
+
+static SCM
+gdbscm_string_to_argv (SCM string_scm)
+{
+ char *string;
+ char **c_argv;
+ int i;
+ SCM result = SCM_EOL;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
+ string_scm, &string);
+
+ if (string == NULL || *string == '\0')
+ {
+ xfree (string);
+ return SCM_EOL;
+ }
+
+ c_argv = gdb_buildargv (string);
+ for (i = 0; c_argv[i] != NULL; ++i)
+ result = scm_cons (gdbscm_scm_from_c_string (c_argv[i]), result);
+
+ freeargv (c_argv);
+ xfree (string);
+
+ return scm_reverse_x (result, SCM_EOL);
+}
+\f
+/* Initialize the Scheme charset interface to GDB. */
+
+static const scheme_function string_functions[] =
+{
+ { "string->argv", 1, 0, 0, gdbscm_string_to_argv,
+ "\
+Convert a string to a list of strings split up according to\n\
+gdb's argv parsing rules." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_strings (void)
+{
+ gdbscm_define_functions (string_functions, 1);
+}
--- /dev/null
+/* Scheme interface to symbols.
+
+ 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 "block.h"
+#include "exceptions.h"
+#include "frame.h"
+#include "symtab.h"
+#include "objfiles.h"
+#include "value.h"
+#include "guile-internal.h"
+
+/* The <gdb:symbol> smob. */
+
+typedef struct
+{
+ /* This always appears first. */
+ eqable_gdb_smob base;
+
+ /* The GDB symbol structure this smob is wrapping. */
+ struct symbol *symbol;
+} symbol_smob;
+
+static const char symbol_smob_name[] = "gdb:symbol";
+
+/* The tag Guile knows the symbol smob by. */
+static scm_t_bits symbol_smob_tag;
+
+/* Keywords used in argument passing. */
+static SCM block_keyword;
+static SCM domain_keyword;
+static SCM frame_keyword;
+
+static const struct objfile_data *syscm_objfile_data_key;
+\f
+/* Administrivia for symbol smobs. */
+
+/* Helper function to hash a symbol_smob. */
+
+static hashval_t
+syscm_hash_symbol_smob (const void *p)
+{
+ const symbol_smob *s_smob = p;
+
+ return htab_hash_pointer (s_smob->symbol);
+}
+
+/* Helper function to compute equality of symbol_smobs. */
+
+static int
+syscm_eq_symbol_smob (const void *ap, const void *bp)
+{
+ const symbol_smob *a = ap;
+ const symbol_smob *b = bp;
+
+ return (a->symbol == b->symbol
+ && a->symbol != NULL);
+}
+
+/* Return the struct symbol pointer -> SCM mapping table.
+ It is created if necessary. */
+
+static htab_t
+syscm_objfile_symbol_map (struct symbol *symbol)
+{
+ struct objfile *objfile = SYMBOL_SYMTAB (symbol)->objfile;
+ htab_t htab = objfile_data (objfile, syscm_objfile_data_key);
+
+ if (htab == NULL)
+ {
+ htab = gdbscm_create_eqable_gsmob_ptr_map (syscm_hash_symbol_smob,
+ syscm_eq_symbol_smob);
+ set_objfile_data (objfile, syscm_objfile_data_key, htab);
+ }
+
+ return htab;
+}
+
+/* The smob "mark" function for <gdb:symbol>. */
+
+static SCM
+syscm_mark_symbol_smob (SCM self)
+{
+ symbol_smob *s_smob = (symbol_smob *) SCM_SMOB_DATA (self);
+
+ /* Do this last. */
+ return gdbscm_mark_eqable_gsmob (&s_smob->base);
+}
+
+/* The smob "free" function for <gdb:symbol>. */
+
+static size_t
+syscm_free_symbol_smob (SCM self)
+{
+ symbol_smob *s_smob = (symbol_smob *) SCM_SMOB_DATA (self);
+
+ if (s_smob->symbol != NULL)
+ {
+ htab_t htab = syscm_objfile_symbol_map (s_smob->symbol);
+
+ gdbscm_clear_eqable_gsmob_ptr_slot (htab, &s_smob->base);
+ }
+
+ /* Not necessary, done to catch bugs. */
+ s_smob->symbol = NULL;
+
+ return 0;
+}
+
+/* The smob "print" function for <gdb:symbol>. */
+
+static int
+syscm_print_symbol_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ symbol_smob *s_smob = (symbol_smob *) SCM_SMOB_DATA (self);
+
+ if (pstate->writingp)
+ gdbscm_printf (port, "#<%s ", symbol_smob_name);
+ gdbscm_printf (port, "%s",
+ s_smob->symbol != NULL
+ ? SYMBOL_PRINT_NAME (s_smob->symbol)
+ : "<invalid>");
+ if (pstate->writingp)
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to create a <gdb:symbol> object. */
+
+static SCM
+syscm_make_symbol_smob (void)
+{
+ symbol_smob *s_smob = (symbol_smob *)
+ scm_gc_malloc (sizeof (symbol_smob), symbol_smob_name);
+ SCM s_scm;
+
+ s_smob->symbol = NULL;
+ s_scm = scm_new_smob (symbol_smob_tag, (scm_t_bits) s_smob);
+ gdbscm_init_eqable_gsmob (&s_smob->base);
+
+ return s_scm;
+}
+
+/* Return non-zero if SCM is a symbol smob. */
+
+int
+syscm_is_symbol (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (symbol_smob_tag, scm);
+}
+
+/* (symbol? object) -> boolean */
+
+static SCM
+gdbscm_symbol_p (SCM scm)
+{
+ return scm_from_bool (syscm_is_symbol (scm));
+}
+
+/* Return the existing object that encapsulates SYMBOL, or create a new
+ <gdb:symbol> object. */
+
+SCM
+syscm_scm_from_symbol (struct symbol *symbol)
+{
+ htab_t htab;
+ eqable_gdb_smob **slot;
+ symbol_smob *s_smob, s_smob_for_lookup;
+ SCM s_scm;
+
+ /* If we've already created a gsmob for this symbol, return it.
+ This makes symbols eq?-able. */
+ htab = syscm_objfile_symbol_map (symbol);
+ s_smob_for_lookup.symbol = symbol;
+ slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &s_smob_for_lookup.base);
+ if (*slot != NULL)
+ return (*slot)->containing_scm;
+
+ s_scm = syscm_make_symbol_smob ();
+ s_smob = (symbol_smob *) SCM_SMOB_DATA (s_scm);
+ s_smob->symbol = symbol;
+ gdbscm_fill_eqable_gsmob_ptr_slot (slot, &s_smob->base, s_scm);
+
+ return s_scm;
+}
+
+/* Returns the <gdb:symbol> object in SELF.
+ Throws an exception if SELF is not a <gdb:symbol> object. */
+
+static SCM
+syscm_get_symbol_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (syscm_is_symbol (self), self, arg_pos, func_name,
+ symbol_smob_name);
+
+ return self;
+}
+
+/* Returns a pointer to the symbol smob of SELF.
+ Throws an exception if SELF is not a <gdb:symbol> object. */
+
+static symbol_smob *
+syscm_get_symbol_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM s_scm = syscm_get_symbol_arg_unsafe (self, arg_pos, func_name);
+ symbol_smob *s_smob = (symbol_smob *) SCM_SMOB_DATA (s_scm);
+
+ return s_smob;
+}
+
+/* Return non-zero if symbol S_SMOB is valid. */
+
+static int
+syscm_is_valid (symbol_smob *s_smob)
+{
+ return s_smob->symbol != NULL;
+}
+
+/* Throw a Scheme error if SELF is not a valid symbol smob.
+ Otherwise return a pointer to the symbol smob. */
+
+static symbol_smob *
+syscm_get_valid_symbol_smob_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ symbol_smob *s_smob
+ = syscm_get_symbol_smob_arg_unsafe (self, arg_pos, func_name);
+
+ if (!syscm_is_valid (s_smob))
+ {
+ gdbscm_invalid_object_error (func_name, arg_pos, self,
+ _("<gdb:symbol>"));
+ }
+
+ return s_smob;
+}
+
+/* Throw a Scheme error if SELF is not a valid symbol smob.
+ Otherwise return a pointer to the symbol struct. */
+
+struct symbol *
+syscm_get_valid_symbol_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ symbol_smob *s_smob = syscm_get_valid_symbol_smob_arg_unsafe (self, arg_pos,
+ func_name);
+
+ return s_smob->symbol;
+}
+
+/* Helper function for syscm_del_objfile_symbols to mark the symbol
+ as invalid. */
+
+static int
+syscm_mark_symbol_invalid (void **slot, void *info)
+{
+ symbol_smob *s_smob = (symbol_smob *) *slot;
+
+ s_smob->symbol = NULL;
+ return 1;
+}
+
+/* This function is called when an objfile is about to be freed.
+ Invalidate the symbol as further actions on the symbol would result
+ in bad data. All access to s_smob->symbol should be gated by
+ syscm_get_valid_symbol_smob_arg_unsafe which will raise an exception on
+ invalid symbols. */
+
+static void
+syscm_del_objfile_symbols (struct objfile *objfile, void *datum)
+{
+ htab_t htab = datum;
+
+ if (htab != NULL)
+ {
+ htab_traverse_noresize (htab, syscm_mark_symbol_invalid, NULL);
+ htab_delete (htab);
+ }
+}
+\f
+/* Symbol methods. */
+
+/* (symbol-valid? <gdb:symbol>) -> boolean
+ Returns #t if SELF still exists in GDB. */
+
+static SCM
+gdbscm_symbol_valid_p (SCM self)
+{
+ symbol_smob *s_smob
+ = syscm_get_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_bool (syscm_is_valid (s_smob));
+}
+
+/* (symbol-type <gdb:symbol>) -> <gdb:type>
+ Return the type of SELF, or #f if SELF has no type. */
+
+static SCM
+gdbscm_symbol_type (SCM self)
+{
+ symbol_smob *s_smob
+ = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct symbol *symbol = s_smob->symbol;
+
+ if (SYMBOL_TYPE (symbol) == NULL)
+ return SCM_BOOL_F;
+
+ return tyscm_scm_from_type (SYMBOL_TYPE (symbol));
+}
+
+/* (symbol-symtab <gdb:symbol>) -> <gdb:symtab>
+ Return the symbol table of SELF. */
+
+static SCM
+gdbscm_symbol_symtab (SCM self)
+{
+ symbol_smob *s_smob
+ = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct symbol *symbol = s_smob->symbol;
+
+ return stscm_scm_from_symtab (SYMBOL_SYMTAB (symbol));
+}
+
+/* (symbol-name <gdb:symbol>) -> string */
+
+static SCM
+gdbscm_symbol_name (SCM self)
+{
+ symbol_smob *s_smob
+ = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct symbol *symbol = s_smob->symbol;
+
+ return gdbscm_scm_from_c_string (SYMBOL_NATURAL_NAME (symbol));
+}
+
+/* (symbol-linkage-name <gdb:symbol>) -> string */
+
+static SCM
+gdbscm_symbol_linkage_name (SCM self)
+{
+ symbol_smob *s_smob
+ = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct symbol *symbol = s_smob->symbol;
+
+ return gdbscm_scm_from_c_string (SYMBOL_LINKAGE_NAME (symbol));
+}
+
+/* (symbol-print-name <gdb:symbol>) -> string */
+
+static SCM
+gdbscm_symbol_print_name (SCM self)
+{
+ symbol_smob *s_smob
+ = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct symbol *symbol = s_smob->symbol;
+
+ return gdbscm_scm_from_c_string (SYMBOL_PRINT_NAME (symbol));
+}
+
+/* (symbol-addr-class <gdb:symbol>) -> integer */
+
+static SCM
+gdbscm_symbol_addr_class (SCM self)
+{
+ symbol_smob *s_smob
+ = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct symbol *symbol = s_smob->symbol;
+
+ return scm_from_int (SYMBOL_CLASS (symbol));
+}
+
+/* (symbol-argument? <gdb:symbol>) -> boolean */
+
+static SCM
+gdbscm_symbol_argument_p (SCM self)
+{
+ symbol_smob *s_smob
+ = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct symbol *symbol = s_smob->symbol;
+
+ return scm_from_bool (SYMBOL_IS_ARGUMENT (symbol));
+}
+
+/* (symbol-constant? <gdb:symbol>) -> boolean */
+
+static SCM
+gdbscm_symbol_constant_p (SCM self)
+{
+ symbol_smob *s_smob
+ = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct symbol *symbol = s_smob->symbol;
+ enum address_class class;
+
+ class = SYMBOL_CLASS (symbol);
+
+ return scm_from_bool (class == LOC_CONST || class == LOC_CONST_BYTES);
+}
+
+/* (symbol-function? <gdb:symbol>) -> boolean */
+
+static SCM
+gdbscm_symbol_function_p (SCM self)
+{
+ symbol_smob *s_smob
+ = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct symbol *symbol = s_smob->symbol;
+ enum address_class class;
+
+ class = SYMBOL_CLASS (symbol);
+
+ return scm_from_bool (class == LOC_BLOCK);
+}
+
+/* (symbol-variable? <gdb:symbol>) -> boolean */
+
+static SCM
+gdbscm_symbol_variable_p (SCM self)
+{
+ symbol_smob *s_smob
+ = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct symbol *symbol = s_smob->symbol;
+ enum address_class class;
+
+ class = SYMBOL_CLASS (symbol);
+
+ return scm_from_bool (!SYMBOL_IS_ARGUMENT (symbol)
+ && (class == LOC_LOCAL || class == LOC_REGISTER
+ || class == LOC_STATIC || class == LOC_COMPUTED
+ || class == LOC_OPTIMIZED_OUT));
+}
+
+/* (symbol-needs-frame? <gdb:symbol>) -> boolean
+ Return #t if the symbol needs a frame for evaluation. */
+
+static SCM
+gdbscm_symbol_needs_frame_p (SCM self)
+{
+ symbol_smob *s_smob
+ = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct symbol *symbol = s_smob->symbol;
+ volatile struct gdb_exception except;
+ int result = 0;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ result = symbol_read_needs_frame (symbol);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return scm_from_bool (result);
+}
+
+/* (symbol-line <gdb:symbol>) -> integer
+ Return the line number at which the symbol was defined. */
+
+static SCM
+gdbscm_symbol_line (SCM self)
+{
+ symbol_smob *s_smob
+ = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct symbol *symbol = s_smob->symbol;
+
+ return scm_from_int (SYMBOL_LINE (symbol));
+}
+
+/* (symbol-value <gdb:symbol> [#:frame <gdb:frame>]) -> <gdb:value>
+ Return the value of the symbol, or an error in various circumstances. */
+
+static SCM
+gdbscm_symbol_value (SCM self, SCM rest)
+{
+ symbol_smob *s_smob
+ = syscm_get_valid_symbol_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct symbol *symbol = s_smob->symbol;
+ SCM keywords[] = { frame_keyword, SCM_BOOL_F };
+ int frame_pos = -1;
+ SCM frame_scm = SCM_BOOL_F;
+ frame_smob *f_smob = NULL;
+ struct frame_info *frame_info = NULL;
+ struct value *value = NULL;
+ volatile struct gdb_exception except;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#O",
+ rest, &frame_pos, &frame_scm);
+ if (!gdbscm_is_false (frame_scm))
+ f_smob = frscm_get_frame_smob_arg_unsafe (frame_scm, frame_pos, FUNC_NAME);
+
+ if (SYMBOL_CLASS (symbol) == LOC_TYPEDEF)
+ {
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
+ _("cannot get the value of a typedef"));
+ }
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (f_smob != NULL)
+ {
+ frame_info = frscm_frame_smob_to_frame (f_smob);
+ if (frame_info == NULL)
+ error (_("Invalid frame"));
+ }
+
+ if (symbol_read_needs_frame (symbol) && frame_info == NULL)
+ error (_("Symbol requires a frame to compute its value"));
+
+ value = read_var_value (symbol, frame_info);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return vlscm_scm_from_value (value);
+}
+\f
+/* (lookup-symbol name [#:block <gdb:block>] [#:domain domain])
+ -> (<gdb:symbol> field-of-this?)
+ The result is #f if the symbol is not found.
+ See comment in lookup_symbol_in_language for field-of-this?. */
+
+static SCM
+gdbscm_lookup_symbol (SCM name_scm, SCM rest)
+{
+ char *name;
+ SCM keywords[] = { block_keyword, domain_keyword, SCM_BOOL_F };
+ const struct block *block = NULL;
+ SCM block_scm = SCM_BOOL_F;
+ int domain = VAR_DOMAIN;
+ int block_arg_pos = -1, domain_arg_pos = -1;
+ struct field_of_this_result is_a_field_of_this;
+ struct symbol *symbol = NULL;
+ volatile struct gdb_exception except;
+ struct cleanup *cleanups;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#Oi",
+ name_scm, &name, rest,
+ &block_arg_pos, &block_scm,
+ &domain_arg_pos, &domain);
+
+ cleanups = make_cleanup (xfree, name);
+
+ if (block_arg_pos >= 0)
+ {
+ SCM except_scm;
+
+ block = bkscm_scm_to_block (block_scm, block_arg_pos, FUNC_NAME,
+ &except_scm);
+ if (block == NULL)
+ {
+ do_cleanups (cleanups);
+ gdbscm_throw (except_scm);
+ }
+ }
+ else
+ {
+ struct frame_info *selected_frame;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ selected_frame = get_selected_frame (_("no frame selected"));
+ block = get_frame_block (selected_frame, NULL);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+ }
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ symbol = lookup_symbol (name, block, domain, &is_a_field_of_this);
+ }
+ do_cleanups (cleanups);
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (symbol == NULL)
+ return SCM_BOOL_F;
+
+ return scm_list_2 (syscm_scm_from_symbol (symbol),
+ scm_from_bool (is_a_field_of_this.type != NULL));
+}
+
+/* (lookup-global-symbol name [#:domain domain]) -> <gdb:symbol>
+ The result is #f if the symbol is not found. */
+
+static SCM
+gdbscm_lookup_global_symbol (SCM name_scm, SCM rest)
+{
+ char *name;
+ SCM keywords[] = { domain_keyword, SCM_BOOL_F };
+ int domain_arg_pos = -1;
+ int domain = VAR_DOMAIN;
+ struct symbol *symbol = NULL;
+ volatile struct gdb_exception except;
+ struct cleanup *cleanups;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#i",
+ name_scm, &name, rest,
+ &domain_arg_pos, &domain);
+
+ cleanups = make_cleanup (xfree, name);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ symbol = lookup_symbol_global (name, NULL, domain);
+ }
+ do_cleanups (cleanups);
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (symbol == NULL)
+ return SCM_BOOL_F;
+
+ return syscm_scm_from_symbol (symbol);
+}
+\f
+/* Initialize the Scheme symbol support. */
+
+/* Note: The SYMBOL_ prefix on the integer constants here is present for
+ compatibility with the Python support. */
+
+static const scheme_integer_constant symbol_integer_constants[] =
+{
+#define X(SYM) { "SYMBOL_" #SYM, SYM }
+ X (LOC_UNDEF),
+ X (LOC_CONST),
+ X (LOC_STATIC),
+ X (LOC_REGISTER),
+ X (LOC_ARG),
+ X (LOC_REF_ARG),
+ X (LOC_LOCAL),
+ X (LOC_TYPEDEF),
+ X (LOC_LABEL),
+ X (LOC_BLOCK),
+ X (LOC_CONST_BYTES),
+ X (LOC_UNRESOLVED),
+ X (LOC_OPTIMIZED_OUT),
+ X (LOC_COMPUTED),
+ X (LOC_REGPARM_ADDR),
+
+ X (UNDEF_DOMAIN),
+ X (VAR_DOMAIN),
+ X (STRUCT_DOMAIN),
+ X (LABEL_DOMAIN),
+ X (VARIABLES_DOMAIN),
+ X (FUNCTIONS_DOMAIN),
+ X (TYPES_DOMAIN),
+#undef X
+
+ END_INTEGER_CONSTANTS
+};
+
+static const scheme_function symbol_functions[] =
+{
+ { "symbol?", 1, 0, 0, gdbscm_symbol_p,
+ "\
+Return #t if the object is a <gdb:symbol> object." },
+
+ { "symbol-valid?", 1, 0, 0, gdbscm_symbol_valid_p,
+ "\
+Return #t if object is a valid <gdb:symbol> object.\n\
+A valid symbol is a symbol that has not been freed.\n\
+Symbols are freed when the objfile they come from is freed." },
+
+ { "symbol-type", 1, 0, 0, gdbscm_symbol_type,
+ "\
+Return the type of symbol." },
+
+ { "symbol-symtab", 1, 0, 0, gdbscm_symbol_symtab,
+ "\
+Return the symbol table (<gdb:symtab>) containing symbol." },
+
+ { "symbol-line", 1, 0, 0, gdbscm_symbol_line,
+ "\
+Return the line number at which the symbol was defined." },
+
+ { "symbol-name", 1, 0, 0, gdbscm_symbol_name,
+ "\
+Return the name of the symbol as a string." },
+
+ { "symbol-linkage-name", 1, 0, 0, gdbscm_symbol_linkage_name,
+ "\
+Return the linkage name of the symbol as a string." },
+
+ { "symbol-print-name", 1, 0, 0, gdbscm_symbol_print_name,
+ "\
+Return the print name of the symbol as a string.\n\
+This is either name or linkage-name, depending on whether the user\n\
+asked GDB to display demangled or mangled names." },
+
+ { "symbol-addr-class", 1, 0, 0, gdbscm_symbol_addr_class,
+ "\
+Return the address class of the symbol." },
+
+ { "symbol-needs-frame?", 1, 0, 0, gdbscm_symbol_needs_frame_p,
+ "\
+Return #t if the symbol needs a frame to compute its value." },
+
+ { "symbol-argument?", 1, 0, 0, gdbscm_symbol_argument_p,
+ "\
+Return #t if the symbol is a function argument." },
+
+ { "symbol-constant?", 1, 0, 0, gdbscm_symbol_constant_p,
+ "\
+Return #t if the symbol is a constant." },
+
+ { "symbol-function?", 1, 0, 0, gdbscm_symbol_function_p,
+ "\
+Return #t if the symbol is a function." },
+
+ { "symbol-variable?", 1, 0, 0, gdbscm_symbol_variable_p,
+ "\
+Return #t if the symbol is a variable." },
+
+ { "symbol-value", 1, 0, 1, gdbscm_symbol_value,
+ "\
+Return the value of the symbol.\n\
+\n\
+ Arguments: <gdb:symbol> [#:frame frame]" },
+
+ { "lookup-symbol", 1, 0, 1, gdbscm_lookup_symbol,
+ "\
+Return (<gdb:symbol> field-of-this?) if found, otherwise #f.\n\
+\n\
+ Arguments: name [#:block block] [#:domain domain]\n\
+ name: a string containing the name of the symbol to lookup\n\
+ block: a <gdb:block> object\n\
+ domain: a SYMBOL_*_DOMAIN value" },
+
+ { "lookup-global-symbol", 1, 0, 1, gdbscm_lookup_global_symbol,
+ "\
+Return <gdb:symbol> if found, otherwise #f.\n\
+\n\
+ Arguments: name [#:domain domain]\n\
+ name: a string containing the name of the symbol to lookup\n\
+ domain: a SYMBOL_*_DOMAIN value" },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_symbols (void)
+{
+ symbol_smob_tag
+ = gdbscm_make_smob_type (symbol_smob_name, sizeof (symbol_smob));
+ scm_set_smob_mark (symbol_smob_tag, syscm_mark_symbol_smob);
+ scm_set_smob_free (symbol_smob_tag, syscm_free_symbol_smob);
+ scm_set_smob_print (symbol_smob_tag, syscm_print_symbol_smob);
+
+ gdbscm_define_integer_constants (symbol_integer_constants, 1);
+ gdbscm_define_functions (symbol_functions, 1);
+
+ block_keyword = scm_from_latin1_keyword ("block");
+ domain_keyword = scm_from_latin1_keyword ("domain");
+ frame_keyword = scm_from_latin1_keyword ("frame");
+
+ /* Register an objfile "free" callback so we can properly
+ invalidate symbols when an object file is about to be deleted. */
+ syscm_objfile_data_key
+ = register_objfile_data_with_cleanup (NULL, syscm_del_objfile_symbols);
+}
--- /dev/null
+/* Scheme interface to symbol tables.
+
+ 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 "symtab.h"
+#include "source.h"
+#include "objfiles.h"
+#include "block.h"
+#include "guile-internal.h"
+
+/* A <gdb:symtab> smob. */
+
+typedef struct
+{
+ /* This always appears first.
+ eqable_gdb_smob is used so that symtabs are eq?-able.
+ Also, a symtab object is associated with an objfile. eqable_gdb_smob
+ lets us track the lifetime of all symtabs associated with an objfile.
+ When an objfile is deleted we need to invalidate the symtab object. */
+ eqable_gdb_smob base;
+
+ /* The GDB symbol table structure.
+ If this is NULL the symtab is invalid. This can happen when the
+ underlying objfile is freed. */
+ struct symtab *symtab;
+} symtab_smob;
+
+/* A <gdb:sal> smob.
+ A smob describing a gdb symtab-and-line object.
+ A sal is associated with an objfile. All access must be gated by checking
+ the validity of symtab_scm.
+ TODO: Sals are not eq?-able at the moment, or even comparable. */
+
+typedef struct
+{
+ /* This always appears first. */
+ gdb_smob base;
+
+ /* The <gdb:symtab> object of the symtab.
+ We store this instead of a pointer to the symtab_smob because it's not
+ clear GC will know the symtab_smob is referenced by us otherwise, and we
+ need quick access to symtab_smob->symtab to know if this sal is valid. */
+ SCM symtab_scm;
+
+ /* The GDB symbol table and line structure.
+ This object is ephemeral in GDB, so keep our own copy.
+ The symtab pointer in this struct is not usable: If the symtab is deleted
+ this pointer will not be updated. Use symtab_scm instead to determine
+ if this sal is valid. */
+ struct symtab_and_line sal;
+} sal_smob;
+
+static const char symtab_smob_name[] = "gdb:symtab";
+/* "symtab-and-line" is pretty long, and "sal" is short and unique. */
+static const char sal_smob_name[] = "gdb:sal";
+
+/* The tags Guile knows the symbol table smobs by. */
+static scm_t_bits symtab_smob_tag;
+static scm_t_bits sal_smob_tag;
+
+static const struct objfile_data *stscm_objfile_data_key;
+\f
+/* Administrivia for symtab smobs. */
+
+/* Helper function to hash a symbol_smob. */
+
+static hashval_t
+stscm_hash_symtab_smob (const void *p)
+{
+ const symtab_smob *st_smob = p;
+
+ return htab_hash_pointer (st_smob->symtab);
+}
+
+/* Helper function to compute equality of symtab_smobs. */
+
+static int
+stscm_eq_symtab_smob (const void *ap, const void *bp)
+{
+ const symtab_smob *a = ap;
+ const symtab_smob *b = bp;
+
+ return (a->symtab == b->symtab
+ && a->symtab != NULL);
+}
+
+/* Return the struct symtab pointer -> SCM mapping table.
+ It is created if necessary. */
+
+static htab_t
+stscm_objfile_symtab_map (struct symtab *symtab)
+{
+ struct objfile *objfile = symtab->objfile;
+ htab_t htab = objfile_data (objfile, stscm_objfile_data_key);
+
+ if (htab == NULL)
+ {
+ htab = gdbscm_create_eqable_gsmob_ptr_map (stscm_hash_symtab_smob,
+ stscm_eq_symtab_smob);
+ set_objfile_data (objfile, stscm_objfile_data_key, htab);
+ }
+
+ return htab;
+}
+
+/* The smob "mark" function for <gdb:symtab>. */
+
+static SCM
+stscm_mark_symtab_smob (SCM self)
+{
+ symtab_smob *st_smob = (symtab_smob *) SCM_SMOB_DATA (self);
+
+ /* Do this last. */
+ return gdbscm_mark_eqable_gsmob (&st_smob->base);
+}
+
+/* The smob "free" function for <gdb:symtab>. */
+
+static size_t
+stscm_free_symtab_smob (SCM self)
+{
+ symtab_smob *st_smob = (symtab_smob *) SCM_SMOB_DATA (self);
+
+ if (st_smob->symtab != NULL)
+ {
+ htab_t htab = stscm_objfile_symtab_map (st_smob->symtab);
+
+ gdbscm_clear_eqable_gsmob_ptr_slot (htab, &st_smob->base);
+ }
+
+ /* Not necessary, done to catch bugs. */
+ st_smob->symtab = NULL;
+
+ return 0;
+}
+
+/* The smob "print" function for <gdb:symtab>. */
+
+static int
+stscm_print_symtab_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ symtab_smob *st_smob = (symtab_smob *) SCM_SMOB_DATA (self);
+
+ gdbscm_printf (port, "#<%s ", symtab_smob_name);
+ gdbscm_printf (port, "%s",
+ st_smob->symtab != NULL
+ ? symtab_to_filename_for_display (st_smob->symtab)
+ : "<invalid>");
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to create a <gdb:symtab> object. */
+
+static SCM
+stscm_make_symtab_smob (void)
+{
+ symtab_smob *st_smob = (symtab_smob *)
+ scm_gc_malloc (sizeof (symtab_smob), symtab_smob_name);
+ SCM st_scm;
+
+ st_smob->symtab = NULL;
+ st_scm = scm_new_smob (symtab_smob_tag, (scm_t_bits) st_smob);
+ gdbscm_init_eqable_gsmob (&st_smob->base);
+
+ return st_scm;
+}
+
+/* Return non-zero if SCM is a symbol table smob. */
+
+static int
+stscm_is_symtab (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (symtab_smob_tag, scm);
+}
+
+/* (symtab? object) -> boolean */
+
+static SCM
+gdbscm_symtab_p (SCM scm)
+{
+ return scm_from_bool (stscm_is_symtab (scm));
+}
+
+/* Create a new <gdb:symtab> object that encapsulates SYMTAB. */
+
+SCM
+stscm_scm_from_symtab (struct symtab *symtab)
+{
+ htab_t htab;
+ eqable_gdb_smob **slot;
+ symtab_smob *st_smob, st_smob_for_lookup;
+ SCM st_scm;
+
+ /* If we've already created a gsmob for this symtab, return it.
+ This makes symtabs eq?-able. */
+ htab = stscm_objfile_symtab_map (symtab);
+ st_smob_for_lookup.symtab = symtab;
+ slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &st_smob_for_lookup.base);
+ if (*slot != NULL)
+ return (*slot)->containing_scm;
+
+ st_scm = stscm_make_symtab_smob ();
+ st_smob = (symtab_smob *) SCM_SMOB_DATA (st_scm);
+ st_smob->symtab = symtab;
+ gdbscm_fill_eqable_gsmob_ptr_slot (slot, &st_smob->base, st_scm);
+
+ return st_scm;
+}
+
+/* Returns the <gdb:symtab> object in SELF.
+ Throws an exception if SELF is not a <gdb:symtab> object. */
+
+static SCM
+stscm_get_symtab_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (stscm_is_symtab (self), self, arg_pos, func_name,
+ symtab_smob_name);
+
+ return self;
+}
+
+/* Returns a pointer to the symtab smob of SELF.
+ Throws an exception if SELF is not a <gdb:symtab> object. */
+
+static symtab_smob *
+stscm_get_symtab_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM st_scm = stscm_get_symtab_arg_unsafe (self, arg_pos, func_name);
+ symtab_smob *st_smob = (symtab_smob *) SCM_SMOB_DATA (st_scm);
+
+ return st_smob;
+}
+
+/* Return non-zero if symtab ST_SMOB is valid. */
+
+static int
+stscm_is_valid (symtab_smob *st_smob)
+{
+ return st_smob->symtab != NULL;
+}
+
+/* Throw a Scheme error if SELF is not a valid symtab smob.
+ Otherwise return a pointer to the symtab_smob object. */
+
+static symtab_smob *
+stscm_get_valid_symtab_smob_arg_unsafe (SCM self, int arg_pos,
+ const char *func_name)
+{
+ symtab_smob *st_smob
+ = stscm_get_symtab_smob_arg_unsafe (self, arg_pos, func_name);
+
+ if (!stscm_is_valid (st_smob))
+ {
+ gdbscm_invalid_object_error (func_name, arg_pos, self,
+ _("<gdb:symtab>"));
+ }
+
+ return st_smob;
+}
+
+/* Helper function for stscm_del_objfile_symtabs to mark the symtab
+ as invalid. */
+
+static int
+stscm_mark_symtab_invalid (void **slot, void *info)
+{
+ symtab_smob *st_smob = (symtab_smob *) *slot;
+
+ st_smob->symtab = NULL;
+ return 1;
+}
+
+/* This function is called when an objfile is about to be freed.
+ Invalidate the symbol table as further actions on the symbol table
+ would result in bad data. All access to st_smob->symtab should be
+ gated by stscm_get_valid_symtab_smob_arg_unsafe which will raise an
+ exception on invalid symbol tables. */
+
+static void
+stscm_del_objfile_symtabs (struct objfile *objfile, void *datum)
+{
+ htab_t htab = datum;
+
+ if (htab != NULL)
+ {
+ htab_traverse_noresize (htab, stscm_mark_symtab_invalid, NULL);
+ htab_delete (htab);
+ }
+}
+\f
+/* Symbol table methods. */
+
+/* (symtab-valid? <gdb:symtab>) -> boolean
+ Returns #t if SELF still exists in GDB. */
+
+static SCM
+gdbscm_symtab_valid_p (SCM self)
+{
+ symtab_smob *st_smob
+ = stscm_get_symtab_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_bool (stscm_is_valid (st_smob));
+}
+
+/* (symtab-filename <gdb:symtab>) -> string */
+
+static SCM
+gdbscm_symtab_filename (SCM self)
+{
+ symtab_smob *st_smob
+ = stscm_get_valid_symtab_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct symtab *symtab = st_smob->symtab;
+
+ return gdbscm_scm_from_c_string (symtab_to_filename_for_display (symtab));
+}
+
+/* (symtab-fullname <gdb:symtab>) -> string */
+
+static SCM
+gdbscm_symtab_fullname (SCM self)
+{
+ symtab_smob *st_smob
+ = stscm_get_valid_symtab_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct symtab *symtab = st_smob->symtab;
+
+ return gdbscm_scm_from_c_string (symtab_to_fullname (symtab));
+}
+
+/* (symtab-objfile <gdb:symtab>) -> <gdb:objfile> */
+
+static SCM
+gdbscm_symtab_objfile (SCM self)
+{
+ symtab_smob *st_smob
+ = stscm_get_valid_symtab_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct symtab *symtab = st_smob->symtab;
+
+ return ofscm_scm_from_objfile (symtab->objfile);
+}
+
+/* (symtab-global-block <gdb:symtab>) -> <gdb:block>
+ Return the GLOBAL_BLOCK of the underlying symtab. */
+
+static SCM
+gdbscm_symtab_global_block (SCM self)
+{
+ symtab_smob *st_smob
+ = stscm_get_valid_symtab_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct symtab *symtab = st_smob->symtab;
+ const struct blockvector *blockvector;
+ const struct block *block;
+
+ blockvector = BLOCKVECTOR (symtab);
+ block = BLOCKVECTOR_BLOCK (blockvector, GLOBAL_BLOCK);
+
+ return bkscm_scm_from_block (block, symtab->objfile);
+}
+
+/* (symtab-static-block <gdb:symtab>) -> <gdb:block>
+ Return the STATIC_BLOCK of the underlying symtab. */
+
+static SCM
+gdbscm_symtab_static_block (SCM self)
+{
+ symtab_smob *st_smob
+ = stscm_get_valid_symtab_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ const struct symtab *symtab = st_smob->symtab;
+ const struct blockvector *blockvector;
+ const struct block *block;
+
+ blockvector = BLOCKVECTOR (symtab);
+ block = BLOCKVECTOR_BLOCK (blockvector, STATIC_BLOCK);
+
+ return bkscm_scm_from_block (block, symtab->objfile);
+}
+\f
+/* Administrivia for sal (symtab-and-line) smobs. */
+
+/* The smob "mark" function for <gdb:sal>. */
+
+static SCM
+stscm_mark_sal_smob (SCM self)
+{
+ sal_smob *s_smob = (sal_smob *) SCM_SMOB_DATA (self);
+
+ scm_gc_mark (s_smob->symtab_scm);
+
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&s_smob->base);
+}
+
+/* The smob "free" function for <gdb:sal>. */
+
+static size_t
+stscm_free_sal_smob (SCM self)
+{
+ sal_smob *s_smob = (sal_smob *) SCM_SMOB_DATA (self);
+
+ /* Not necessary, done to catch bugs. */
+ s_smob->symtab_scm = SCM_UNDEFINED;
+
+ return 0;
+}
+
+/* The smob "print" function for <gdb:sal>. */
+
+static int
+stscm_print_sal_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ sal_smob *s_smob = (sal_smob *) SCM_SMOB_DATA (self);
+ symtab_smob *st_smob = (symtab_smob *) SCM_SMOB_DATA (s_smob->symtab_scm);
+
+ gdbscm_printf (port, "#<%s ", symtab_smob_name);
+ scm_write (s_smob->symtab_scm, port);
+ if (s_smob->sal.line != 0)
+ gdbscm_printf (port, " line %d", s_smob->sal.line);
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to create a <gdb:sal> object. */
+
+static SCM
+stscm_make_sal_smob (void)
+{
+ sal_smob *s_smob
+ = (sal_smob *) scm_gc_malloc (sizeof (sal_smob), sal_smob_name);
+ SCM s_scm;
+
+ s_smob->symtab_scm = SCM_BOOL_F;
+ memset (&s_smob->sal, 0, sizeof (s_smob->sal));
+ s_scm = scm_new_smob (sal_smob_tag, (scm_t_bits) s_smob);
+ gdbscm_init_gsmob (&s_smob->base);
+
+ return s_scm;
+}
+
+/* Return non-zero if SCM is a <gdb:sal> object. */
+
+static int
+stscm_is_sal (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (sal_smob_tag, scm);
+}
+
+/* (sal? object) -> boolean */
+
+static SCM
+gdbscm_sal_p (SCM scm)
+{
+ return scm_from_bool (stscm_is_sal (scm));
+}
+
+/* Create a new <gdb:sal> object that encapsulates SAL. */
+
+SCM
+stscm_scm_from_sal (struct symtab_and_line sal)
+{
+ SCM st_scm, s_scm;
+ sal_smob *s_smob;
+
+ st_scm = SCM_BOOL_F;
+ if (sal.symtab != NULL)
+ st_scm = stscm_scm_from_symtab (sal.symtab);
+
+ s_scm = stscm_make_sal_smob ();
+ s_smob = (sal_smob *) SCM_SMOB_DATA (s_scm);
+ s_smob->symtab_scm = st_scm;
+ s_smob->sal = sal;
+
+ return s_scm;
+}
+
+/* Returns the <gdb:sal> object in SELF.
+ Throws an exception if SELF is not a <gdb:sal> object. */
+
+static SCM
+stscm_get_sal_arg (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (stscm_is_sal (self), self, arg_pos, func_name,
+ sal_smob_name);
+
+ return self;
+}
+
+/* Returns a pointer to the sal smob of SELF.
+ Throws an exception if SELF is not a <gdb:sal> object. */
+
+static sal_smob *
+stscm_get_sal_smob_arg (SCM self, int arg_pos, const char *func_name)
+{
+ SCM s_scm = stscm_get_sal_arg (self, arg_pos, func_name);
+ sal_smob *s_smob = (sal_smob *) SCM_SMOB_DATA (s_scm);
+
+ return s_smob;
+}
+
+/* Return non-zero if the symtab in S_SMOB is valid. */
+
+static int
+stscm_sal_is_valid (sal_smob *s_smob)
+{
+ symtab_smob *st_smob;
+
+ /* If there's no symtab that's ok, the sal is still valid. */
+ if (gdbscm_is_false (s_smob->symtab_scm))
+ return 1;
+
+ st_smob = (symtab_smob *) SCM_SMOB_DATA (s_smob->symtab_scm);
+
+ return st_smob->symtab != NULL;
+}
+
+/* Throw a Scheme error if SELF is not a valid sal smob.
+ Otherwise return a pointer to the sal_smob object. */
+
+static sal_smob *
+stscm_get_valid_sal_smob_arg (SCM self, int arg_pos, const char *func_name)
+{
+ sal_smob *s_smob = stscm_get_sal_smob_arg (self, arg_pos, func_name);
+
+ if (!stscm_sal_is_valid (s_smob))
+ {
+ gdbscm_invalid_object_error (func_name, arg_pos, self,
+ _("<gdb:sal>"));
+ }
+
+ return s_smob;
+}
+\f
+/* sal methods */
+
+/* (sal-valid? <gdb:sal>) -> boolean
+ Returns #t if the symtab for SELF still exists in GDB. */
+
+static SCM
+gdbscm_sal_valid_p (SCM self)
+{
+ sal_smob *s_smob = stscm_get_sal_smob_arg (self, SCM_ARG1, FUNC_NAME);
+
+ return scm_from_bool (stscm_sal_is_valid (s_smob));
+}
+
+/* (sal-pc <gdb:sal>) -> address */
+
+static SCM
+gdbscm_sal_pc (SCM self)
+{
+ sal_smob *s_smob = stscm_get_valid_sal_smob_arg (self, SCM_ARG1, FUNC_NAME);
+ const struct symtab_and_line *sal = &s_smob->sal;
+
+ return gdbscm_scm_from_ulongest (sal->pc);
+}
+
+/* (sal-last <gdb:sal>) -> address
+ Returns #f if no ending address is recorded. */
+
+static SCM
+gdbscm_sal_last (SCM self)
+{
+ sal_smob *s_smob = stscm_get_valid_sal_smob_arg (self, SCM_ARG1, FUNC_NAME);
+ const struct symtab_and_line *sal = &s_smob->sal;
+
+ if (sal->end > 0)
+ return gdbscm_scm_from_ulongest (sal->end - 1);
+ return SCM_BOOL_F;
+}
+
+/* (sal-line <gdb:sal>) -> integer
+ Returns #f if no line number is recorded. */
+
+static SCM
+gdbscm_sal_line (SCM self)
+{
+ sal_smob *s_smob = stscm_get_valid_sal_smob_arg (self, SCM_ARG1, FUNC_NAME);
+ const struct symtab_and_line *sal = &s_smob->sal;
+
+ if (sal->line > 0)
+ return scm_from_int (sal->line);
+ return SCM_BOOL_F;
+}
+
+/* (sal-symtab <gdb:sal>) -> <gdb:symtab>
+ Returns #f if no symtab is recorded. */
+
+static SCM
+gdbscm_sal_symtab (SCM self)
+{
+ sal_smob *s_smob = stscm_get_valid_sal_smob_arg (self, SCM_ARG1, FUNC_NAME);
+ const struct symtab_and_line *sal = &s_smob->sal;
+
+ return s_smob->symtab_scm;
+}
+
+/* (find-pc-line address) -> <gdb:sal> */
+
+static SCM
+gdbscm_find_pc_line (SCM pc_scm)
+{
+ ULONGEST pc_ull;
+ struct symtab_and_line sal;
+ volatile struct gdb_exception except;
+
+ init_sal (&sal); /* -Wall */
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "U", pc_scm, &pc_ull);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ CORE_ADDR pc = (CORE_ADDR) pc_ull;
+
+ sal = find_pc_line (pc, 0);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return stscm_scm_from_sal (sal);
+}
+\f
+/* Initialize the Scheme symbol support. */
+
+static const scheme_function symtab_functions[] =
+{
+ { "symtab?", 1, 0, 0, gdbscm_symtab_p,
+ "\
+Return #t if the object is a <gdb:symtab> object." },
+
+ { "symtab-valid?", 1, 0, 0, gdbscm_symtab_valid_p,
+ "\
+Return #t if the symtab still exists in GDB.\n\
+Symtabs are deleted when the corresponding objfile is freed." },
+
+ { "symtab-filename", 1, 0, 0, gdbscm_symtab_filename,
+ "\
+Return the symtab's source file name." },
+
+ { "symtab-fullname", 1, 0, 0, gdbscm_symtab_fullname,
+ "\
+Return the symtab's full source file name." },
+
+ { "symtab-objfile", 1, 0, 0, gdbscm_symtab_objfile,
+ "\
+Return the symtab's objfile." },
+
+ { "symtab-global-block", 1, 0, 0, gdbscm_symtab_global_block,
+ "\
+Return the symtab's global block." },
+
+ { "symtab-static-block", 1, 0, 0, gdbscm_symtab_static_block,
+ "\
+Return the symtab's static block." },
+
+ { "sal?", 1, 0, 0, gdbscm_sal_p,
+ "\
+Return #t if the object is a <gdb:sal> (symtab-and-line) object." },
+
+ { "sal-valid?", 1, 0, 0, gdbscm_sal_valid_p,
+ "\
+Return #t if the symtab for the sal still exists in GDB.\n\
+Symtabs are deleted when the corresponding objfile is freed." },
+
+ { "sal-symtab", 1, 0, 0, gdbscm_sal_symtab,
+ "\
+Return the sal's symtab." },
+
+ { "sal-line", 1, 0, 0, gdbscm_sal_line,
+ "\
+Return the sal's line number, or #f if there is none." },
+
+ { "sal-pc", 1, 0, 0, gdbscm_sal_pc,
+ "\
+Return the sal's address." },
+
+ { "sal-last", 1, 0, 0, gdbscm_sal_last,
+ "\
+Return the last address specified by the sal, or #f if there is none." },
+
+ { "find-pc-line", 1, 0, 0, gdbscm_find_pc_line,
+ "\
+Return the sal corresponding to the address, or #f if there isn't one.\n\
+\n\
+ Arguments: address" },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_symtabs (void)
+{
+ symtab_smob_tag
+ = gdbscm_make_smob_type (symtab_smob_name, sizeof (symtab_smob));
+ scm_set_smob_mark (symtab_smob_tag, stscm_mark_symtab_smob);
+ scm_set_smob_free (symtab_smob_tag, stscm_free_symtab_smob);
+ scm_set_smob_print (symtab_smob_tag, stscm_print_symtab_smob);
+
+ sal_smob_tag = gdbscm_make_smob_type (sal_smob_name, sizeof (sal_smob));
+ scm_set_smob_mark (sal_smob_tag, stscm_mark_sal_smob);
+ scm_set_smob_free (sal_smob_tag, stscm_free_sal_smob);
+ scm_set_smob_print (sal_smob_tag, stscm_print_sal_smob);
+
+ gdbscm_define_functions (symtab_functions, 1);
+
+ /* Register an objfile "free" callback so we can properly
+ invalidate symbol tables, and symbol table and line data
+ structures when an object file that is about to be deleted. */
+ stscm_objfile_data_key
+ = register_objfile_data_with_cleanup (NULL, stscm_del_objfile_symtabs);
+}
--- /dev/null
+/* Scheme interface to types.
+
+ 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 "arch-utils.h"
+#include "value.h"
+#include "exceptions.h"
+#include "gdbtypes.h"
+#include "objfiles.h"
+#include "language.h"
+#include "vec.h"
+#include "bcache.h"
+#include "dwarf2loc.h"
+#include "typeprint.h"
+#include "guile-internal.h"
+
+/* The <gdb:type> smob.
+ The type is chained with all types associated with its objfile, if any.
+ This lets us copy the underlying struct type when the objfile is
+ deleted. */
+
+typedef struct _type_smob
+{
+ /* This always appears first.
+ eqable_gdb_smob is used so that types are eq?-able.
+ Also, a type object can be associated with an objfile. eqable_gdb_smob
+ lets us track the lifetime of all types associated with an objfile.
+ When an objfile is deleted we need to invalidate the type object. */
+ eqable_gdb_smob base;
+
+ /* The GDB type structure this smob is wrapping. */
+ struct type *type;
+} type_smob;
+
+/* A field smob. */
+
+typedef struct
+{
+ /* This always appears first. */
+ gdb_smob base;
+
+ /* Backlink to the containing <gdb:type> object. */
+ SCM type_scm;
+
+ /* The field number in TYPE_SCM. */
+ int field_num;
+} field_smob;
+
+static const char type_smob_name[] = "gdb:type";
+static const char field_smob_name[] = "gdb:field";
+
+static const char not_composite_error[] =
+ N_("type is not a structure, union, or enum type");
+
+/* The tag Guile knows the type smob by. */
+static scm_t_bits type_smob_tag;
+
+/* The tag Guile knows the field smob by. */
+static scm_t_bits field_smob_tag;
+
+/* The "next" procedure for field iterators. */
+static SCM tyscm_next_field_x_proc;
+
+/* Keywords used in argument passing. */
+static SCM block_keyword;
+
+static const struct objfile_data *tyscm_objfile_data_key;
+
+/* Hash table to uniquify global (non-objfile-owned) types. */
+static htab_t global_types_map;
+
+static struct type *tyscm_get_composite (struct type *type);
+
+/* Return the type field of T_SMOB.
+ This exists so that we don't have to export the struct's contents. */
+
+struct type *
+tyscm_type_smob_type (type_smob *t_smob)
+{
+ return t_smob->type;
+}
+
+/* Return the name of TYPE in expanded form.
+ Space for the result is malloc'd, caller must free.
+ If there's an error computing the name, the result is NULL and the
+ exception is stored in *EXCP. */
+
+static char *
+tyscm_type_name (struct type *type, SCM *excp)
+{
+ char *name = NULL;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct cleanup *old_chain;
+ struct ui_file *stb;
+
+ stb = mem_fileopen ();
+ old_chain = make_cleanup_ui_file_delete (stb);
+
+ LA_PRINT_TYPE (type, "", stb, -1, 0, &type_print_raw_options);
+
+ name = ui_file_xstrdup (stb, NULL);
+ do_cleanups (old_chain);
+ }
+ if (except.reason < 0)
+ {
+ *excp = gdbscm_scm_from_gdb_exception (except);
+ return NULL;
+ }
+
+ return name;
+}
+\f
+/* Administrivia for type smobs. */
+
+/* Helper function to hash a type_smob. */
+
+static hashval_t
+tyscm_hash_type_smob (const void *p)
+{
+ const type_smob *t_smob = p;
+
+ return htab_hash_pointer (t_smob->type);
+}
+
+/* Helper function to compute equality of type_smobs. */
+
+static int
+tyscm_eq_type_smob (const void *ap, const void *bp)
+{
+ const type_smob *a = ap;
+ const type_smob *b = bp;
+
+ return (a->type == b->type
+ && a->type != NULL);
+}
+
+/* Return the struct type pointer -> SCM mapping table.
+ If type is owned by an objfile, the mapping table is created if necessary.
+ Otherwise, type is not owned by an objfile, and we use
+ global_types_map. */
+
+static htab_t
+tyscm_type_map (struct type *type)
+{
+ struct objfile *objfile = TYPE_OBJFILE (type);
+ htab_t htab;
+
+ if (objfile == NULL)
+ return global_types_map;
+
+ htab = objfile_data (objfile, tyscm_objfile_data_key);
+ if (htab == NULL)
+ {
+ htab = gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob,
+ tyscm_eq_type_smob);
+ set_objfile_data (objfile, tyscm_objfile_data_key, htab);
+ }
+
+ return htab;
+}
+
+/* The smob "mark" function for <gdb:type>. */
+
+static SCM
+tyscm_mark_type_smob (SCM self)
+{
+ type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (self);
+
+ /* Do this last. */
+ return gdbscm_mark_eqable_gsmob (&t_smob->base);
+}
+
+/* The smob "free" function for <gdb:type>. */
+
+static size_t
+tyscm_free_type_smob (SCM self)
+{
+ type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (self);
+
+ if (t_smob->type != NULL)
+ {
+ htab_t htab = tyscm_type_map (t_smob->type);
+
+ gdbscm_clear_eqable_gsmob_ptr_slot (htab, &t_smob->base);
+ }
+
+ /* Not necessary, done to catch bugs. */
+ t_smob->type = NULL;
+
+ return 0;
+}
+
+/* The smob "print" function for <gdb:type>. */
+
+static int
+tyscm_print_type_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (self);
+ SCM exception;
+ char *name = tyscm_type_name (t_smob->type, &exception);
+
+ if (name == NULL)
+ gdbscm_throw (exception);
+
+ /* pstate->writingp = zero if invoked by display/~A, and nonzero if
+ invoked by write/~S. What to do here may need to evolve.
+ IWBN if we could pass an argument to format that would we could use
+ instead of writingp. */
+ if (pstate->writingp)
+ gdbscm_printf (port, "#<%s ", type_smob_name);
+
+ scm_puts (name, port);
+
+ if (pstate->writingp)
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* The smob "equal?" function for <gdb:type>. */
+
+static SCM
+tyscm_equal_p_type_smob (SCM type1_scm, SCM type2_scm)
+{
+ type_smob *type1_smob, *type2_smob;
+ struct type *type1, *type2;
+ int result = 0;
+ volatile struct gdb_exception except;
+
+ SCM_ASSERT_TYPE (tyscm_is_type (type1_scm), type1_scm, SCM_ARG1, FUNC_NAME,
+ type_smob_name);
+ SCM_ASSERT_TYPE (tyscm_is_type (type2_scm), type2_scm, SCM_ARG2, FUNC_NAME,
+ type_smob_name);
+ type1_smob = (type_smob *) SCM_SMOB_DATA (type1_scm);
+ type2_smob = (type_smob *) SCM_SMOB_DATA (type2_scm);
+ type1 = type1_smob->type;
+ type2 = type2_smob->type;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ result = types_deeply_equal (type1, type2);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return scm_from_bool (result);
+}
+
+/* Low level routine to create a <gdb:type> object. */
+
+static SCM
+tyscm_make_type_smob (void)
+{
+ type_smob *t_smob = (type_smob *)
+ scm_gc_malloc (sizeof (type_smob), type_smob_name);
+ SCM t_scm;
+
+ /* This must be filled in by the caller. */
+ t_smob->type = NULL;
+
+ t_scm = scm_new_smob (type_smob_tag, (scm_t_bits) t_smob);
+ gdbscm_init_eqable_gsmob (&t_smob->base);
+
+ return t_scm;
+}
+
+/* Return non-zero if SCM is a <gdb:type> object. */
+
+int
+tyscm_is_type (SCM self)
+{
+ return SCM_SMOB_PREDICATE (type_smob_tag, self);
+}
+
+/* (type? object) -> boolean */
+
+static SCM
+gdbscm_type_p (SCM self)
+{
+ return scm_from_bool (tyscm_is_type (self));
+}
+
+/* Return the existing object that encapsulates TYPE, or create a new
+ <gdb:type> object. */
+
+SCM
+tyscm_scm_from_type (struct type *type)
+{
+ htab_t htab;
+ eqable_gdb_smob **slot;
+ type_smob *t_smob, t_smob_for_lookup;
+ SCM t_scm;
+
+ /* If we've already created a gsmob for this type, return it.
+ This makes types eq?-able. */
+ htab = tyscm_type_map (type);
+ t_smob_for_lookup.type = type;
+ slot = gdbscm_find_eqable_gsmob_ptr_slot (htab, &t_smob_for_lookup.base);
+ if (*slot != NULL)
+ return (*slot)->containing_scm;
+
+ t_scm = tyscm_make_type_smob ();
+ t_smob = (type_smob *) SCM_SMOB_DATA (t_scm);
+ t_smob->type = type;
+ gdbscm_fill_eqable_gsmob_ptr_slot (slot, &t_smob->base, t_scm);
+
+ return t_scm;
+}
+
+/* Returns the <gdb:type> object in SELF.
+ Throws an exception if SELF is not a <gdb:type> object. */
+
+static SCM
+tyscm_get_type_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (tyscm_is_type (self), self, arg_pos, func_name,
+ type_smob_name);
+
+ return self;
+}
+
+/* Returns a pointer to the type smob of SELF.
+ Throws an exception if SELF is not a <gdb:type> object. */
+
+type_smob *
+tyscm_get_type_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM t_scm = tyscm_get_type_arg_unsafe (self, arg_pos, func_name);
+ type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (t_scm);
+
+ return t_smob;
+}
+
+/* Helper function for save_objfile_types to make a deep copy of the type. */
+
+static int
+tyscm_copy_type_recursive (void **slot, void *info)
+{
+ type_smob *t_smob = (type_smob *) *slot;
+ htab_t copied_types = info;
+ struct objfile *objfile = TYPE_OBJFILE (t_smob->type);
+
+ gdb_assert (objfile != NULL);
+
+ htab_empty (copied_types);
+ t_smob->type = copy_type_recursive (objfile, t_smob->type, copied_types);
+ return 1;
+}
+
+/* Called when OBJFILE is about to be deleted.
+ Make a copy of all types associated with OBJFILE. */
+
+static void
+save_objfile_types (struct objfile *objfile, void *datum)
+{
+ htab_t htab = datum;
+ htab_t copied_types;
+
+ if (!gdb_scheme_initialized)
+ return;
+
+ copied_types = create_copied_types_hash (objfile);
+
+ if (htab != NULL)
+ {
+ htab_traverse_noresize (htab, tyscm_copy_type_recursive, copied_types);
+ htab_delete (htab);
+ }
+
+ htab_delete (copied_types);
+}
+\f
+/* Administrivia for field smobs. */
+
+/* The smob "mark" function for <gdb:field>. */
+
+static SCM
+tyscm_mark_field_smob (SCM self)
+{
+ field_smob *f_smob = (field_smob *) SCM_SMOB_DATA (self);
+
+ scm_gc_mark (f_smob->type_scm);
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&f_smob->base);
+}
+
+/* The smob "print" function for <gdb:field>. */
+
+static int
+tyscm_print_field_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ field_smob *f_smob = (field_smob *) SCM_SMOB_DATA (self);
+
+ gdbscm_printf (port, "#<%s ", field_smob_name);
+ scm_write (f_smob->type_scm, port);
+ gdbscm_printf (port, " %d", f_smob->field_num);
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* Low level routine to create a <gdb:field> object for field FIELD_NUM
+ of type TYPE_SCM. */
+
+static SCM
+tyscm_make_field_smob (SCM type_scm, int field_num)
+{
+ field_smob *f_smob = (field_smob *)
+ scm_gc_malloc (sizeof (field_smob), field_smob_name);
+ SCM result;
+
+ f_smob->type_scm = type_scm;
+ f_smob->field_num = field_num;
+ result = scm_new_smob (field_smob_tag, (scm_t_bits) f_smob);
+ gdbscm_init_gsmob (&f_smob->base);
+
+ return result;
+}
+
+/* Return non-zero if SCM is a <gdb:field> object. */
+
+static int
+tyscm_is_field (SCM self)
+{
+ return SCM_SMOB_PREDICATE (field_smob_tag, self);
+}
+
+/* (field? object) -> boolean */
+
+static SCM
+gdbscm_field_p (SCM self)
+{
+ return scm_from_bool (tyscm_is_field (self));
+}
+
+/* Create a new <gdb:field> object that encapsulates field FIELD_NUM
+ in type TYPE_SCM. */
+
+SCM
+tyscm_scm_from_field (SCM type_scm, int field_num)
+{
+ return tyscm_make_field_smob (type_scm, field_num);
+}
+
+/* Returns the <gdb:field> object in SELF.
+ Throws an exception if SELF is not a <gdb:field> object. */
+
+static SCM
+tyscm_get_field_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (tyscm_is_field (self), self, arg_pos, func_name,
+ field_smob_name);
+
+ return self;
+}
+
+/* Returns a pointer to the field smob of SELF.
+ Throws an exception if SELF is not a <gdb:field> object. */
+
+static field_smob *
+tyscm_get_field_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM f_scm = tyscm_get_field_arg_unsafe (self, arg_pos, func_name);
+ field_smob *f_smob = (field_smob *) SCM_SMOB_DATA (f_scm);
+
+ return f_smob;
+}
+
+/* Returns a pointer to the type struct in F_SMOB
+ (the type the field is in). */
+
+static struct type *
+tyscm_field_smob_containing_type (field_smob *f_smob)
+{
+ type_smob *t_smob;
+
+ gdb_assert (tyscm_is_type (f_smob->type_scm));
+ t_smob = (type_smob *) SCM_SMOB_DATA (f_smob->type_scm);
+
+ return t_smob->type;
+}
+
+/* Returns a pointer to the field struct of F_SMOB. */
+
+static struct field *
+tyscm_field_smob_to_field (field_smob *f_smob)
+{
+ struct type *type = tyscm_field_smob_containing_type (f_smob);
+
+ /* This should be non-NULL by construction. */
+ gdb_assert (TYPE_FIELDS (type) != NULL);
+
+ return &TYPE_FIELD (type, f_smob->field_num);
+}
+\f
+/* Type smob accessors. */
+
+/* (type-code <gdb:type>) -> integer
+ Return the code for this type. */
+
+static SCM
+gdbscm_type_code (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+
+ return scm_from_int (TYPE_CODE (type));
+}
+
+/* (type-fields <gdb:type>) -> list
+ Return a list of all fields. Each element is a <gdb:field> object.
+ This also supports arrays, we return a field list of one element,
+ the range type. */
+
+static SCM
+gdbscm_type_fields (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+ struct type *containing_type;
+ SCM containing_type_scm, result;
+ int i;
+
+ containing_type = tyscm_get_composite (type);
+ if (containing_type == NULL)
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
+ _(not_composite_error));
+
+ /* If SELF is a typedef or reference, we want the underlying type,
+ which is what tyscm_get_composite returns. */
+ if (containing_type == type)
+ containing_type_scm = self;
+ else
+ containing_type_scm = tyscm_scm_from_type (containing_type);
+
+ result = SCM_EOL;
+ for (i = 0; i < TYPE_NFIELDS (containing_type); ++i)
+ result = scm_cons (tyscm_make_field_smob (containing_type_scm, i), result);
+
+ return scm_reverse_x (result, SCM_EOL);
+}
+
+/* (type-tag <gdb:type>) -> string
+ Return the type's tag, or #f. */
+
+static SCM
+gdbscm_type_tag (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+
+ if (!TYPE_TAG_NAME (type))
+ return SCM_BOOL_F;
+ return gdbscm_scm_from_c_string (TYPE_TAG_NAME (type));
+}
+
+/* (type-name <gdb:type>) -> string
+ Return the type's name, or #f. */
+
+static SCM
+gdbscm_type_name (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+
+ if (!TYPE_NAME (type))
+ return SCM_BOOL_F;
+ return gdbscm_scm_from_c_string (TYPE_NAME (type));
+}
+
+/* (type-print-name <gdb:type>) -> string
+ Return the print name of type.
+ TODO: template support elided for now. */
+
+static SCM
+gdbscm_type_print_name (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+ char *thetype;
+ SCM exception, result;
+
+ thetype = tyscm_type_name (type, &exception);
+
+ if (thetype == NULL)
+ gdbscm_throw (exception);
+
+ result = gdbscm_scm_from_c_string (thetype);
+ xfree (thetype);
+
+ return result;
+}
+
+/* (type-sizeof <gdb:type>) -> integer
+ Return the size of the type represented by SELF, in bytes. */
+
+static SCM
+gdbscm_type_sizeof (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ check_typedef (type);
+ }
+ /* Ignore exceptions. */
+
+ return scm_from_long (TYPE_LENGTH (type));
+}
+
+/* (type-strip-typedefs <gdb:type>) -> <gdb:type>
+ Return the type, stripped of typedefs. */
+
+static SCM
+gdbscm_type_strip_typedefs (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ type = check_typedef (type);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return tyscm_scm_from_type (type);
+}
+
+/* Strip typedefs and pointers/reference from a type. Then check that
+ it is a struct, union, or enum type. If not, return NULL. */
+
+static struct type *
+tyscm_get_composite (struct type *type)
+{
+ volatile struct gdb_exception except;
+
+ for (;;)
+ {
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ type = check_typedef (type);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (TYPE_CODE (type) != TYPE_CODE_PTR
+ && TYPE_CODE (type) != TYPE_CODE_REF)
+ break;
+ type = TYPE_TARGET_TYPE (type);
+ }
+
+ /* If this is not a struct, union, or enum type, raise TypeError
+ exception. */
+ if (TYPE_CODE (type) != TYPE_CODE_STRUCT
+ && TYPE_CODE (type) != TYPE_CODE_UNION
+ && TYPE_CODE (type) != TYPE_CODE_ENUM)
+ return NULL;
+
+ return type;
+}
+
+/* Helper for tyscm_array and tyscm_vector. */
+
+static SCM
+tyscm_array_1 (SCM self, SCM n1_scm, SCM n2_scm, int is_vector,
+ const char *func_name)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, func_name);
+ struct type *type = t_smob->type;
+ long n1, n2 = 0;
+ struct type *array = NULL;
+ volatile struct gdb_exception except;
+
+ gdbscm_parse_function_args (func_name, SCM_ARG2, NULL, "l|l",
+ n1_scm, &n1, n2_scm, &n2);
+
+ if (SCM_UNBNDP (n2_scm))
+ {
+ n2 = n1;
+ n1 = 0;
+ }
+
+ if (n2 < n1)
+ {
+ gdbscm_out_of_range_error (func_name, SCM_ARG3,
+ scm_cons (scm_from_long (n1),
+ scm_from_long (n2)),
+ _("Array length must not be negative"));
+ }
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ array = lookup_array_range_type (type, n1, n2);
+ if (is_vector)
+ make_vector_type (array);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return tyscm_scm_from_type (array);
+}
+
+/* (type-array <gdb:type> [low-bound] high-bound) -> <gdb:type>
+ The array has indices [low-bound,high-bound].
+ If low-bound is not provided zero is used.
+ Return an array type.
+
+ IWBN if the one argument version specified a size, not the high bound.
+ It's too easy to pass one argument thinking it is the size of the array.
+ The current semantics are for compatibility with the Python version.
+ Later we can add #:size. */
+
+static SCM
+gdbscm_type_array (SCM self, SCM n1, SCM n2)
+{
+ return tyscm_array_1 (self, n1, n2, 0, FUNC_NAME);
+}
+
+/* (type-vector <gdb:type> [low-bound] high-bound) -> <gdb:type>
+ The array has indices [low-bound,high-bound].
+ If low-bound is not provided zero is used.
+ Return a vector type.
+
+ IWBN if the one argument version specified a size, not the high bound.
+ It's too easy to pass one argument thinking it is the size of the array.
+ The current semantics are for compatibility with the Python version.
+ Later we can add #:size. */
+
+static SCM
+gdbscm_type_vector (SCM self, SCM n1, SCM n2)
+{
+ return tyscm_array_1 (self, n1, n2, 1, FUNC_NAME);
+}
+
+/* (type-pointer <gdb:type>) -> <gdb:type>
+ Return a <gdb:type> object which represents a pointer to SELF. */
+
+static SCM
+gdbscm_type_pointer (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ type = lookup_pointer_type (type);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (type-range <gdb:type>) -> (low high)
+ Return the range of a type represented by SELF. The return type is
+ a list. The first element is the low bound, and the second element
+ is the high bound. */
+
+static SCM
+gdbscm_type_range (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+ SCM low_scm, high_scm;
+ /* Initialize these to appease GCC warnings. */
+ LONGEST low = 0, high = 0;
+
+ SCM_ASSERT_TYPE (TYPE_CODE (type) == TYPE_CODE_ARRAY
+ || TYPE_CODE (type) == TYPE_CODE_STRING
+ || TYPE_CODE (type) == TYPE_CODE_RANGE,
+ self, SCM_ARG1, FUNC_NAME, _("ranged type"));
+
+ switch (TYPE_CODE (type))
+ {
+ case TYPE_CODE_ARRAY:
+ case TYPE_CODE_STRING:
+ low = TYPE_LOW_BOUND (TYPE_INDEX_TYPE (type));
+ high = TYPE_HIGH_BOUND (TYPE_INDEX_TYPE (type));
+ break;
+ case TYPE_CODE_RANGE:
+ low = TYPE_LOW_BOUND (type);
+ high = TYPE_HIGH_BOUND (type);
+ break;
+ }
+
+ low_scm = gdbscm_scm_from_longest (low);
+ high_scm = gdbscm_scm_from_longest (high);
+
+ return scm_list_2 (low_scm, high_scm);
+}
+
+/* (type-reference <gdb:type>) -> <gdb:type>
+ Return a <gdb:type> object which represents a reference to SELF. */
+
+static SCM
+gdbscm_type_reference (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ type = lookup_reference_type (type);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (type-target <gdb:type>) -> <gdb:type>
+ Return a <gdb:type> object which represents the target type of SELF. */
+
+static SCM
+gdbscm_type_target (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+
+ SCM_ASSERT (TYPE_TARGET_TYPE (type), self, SCM_ARG1, FUNC_NAME);
+
+ return tyscm_scm_from_type (TYPE_TARGET_TYPE (type));
+}
+
+/* (type-const <gdb:type>) -> <gdb:type>
+ Return a const-qualified type variant. */
+
+static SCM
+gdbscm_type_const (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ type = make_cv_type (1, 0, type, NULL);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (type-volatile <gdb:type>) -> <gdb:type>
+ Return a volatile-qualified type variant. */
+
+static SCM
+gdbscm_type_volatile (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ type = make_cv_type (0, 1, type, NULL);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return tyscm_scm_from_type (type);
+}
+
+/* (type-unqualified <gdb:type>) -> <gdb:type>
+ Return an unqualified type variant. */
+
+static SCM
+gdbscm_type_unqualified (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ type = make_cv_type (0, 0, type, NULL);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return tyscm_scm_from_type (type);
+}
+\f
+/* Field related accessors of types. */
+
+/* (type-num-fields <gdb:type>) -> integer
+ Return number of fields. */
+
+static SCM
+gdbscm_type_num_fields (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+
+ type = tyscm_get_composite (type);
+ if (type == NULL)
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
+ _(not_composite_error));
+
+ return scm_from_long (TYPE_NFIELDS (type));
+}
+
+/* (type-field <gdb:type> string) -> <gdb:field>
+ Return the <gdb:field> object for the field named by the argument. */
+
+static SCM
+gdbscm_type_field (SCM self, SCM field_scm)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+ char *field;
+ int i;
+ struct cleanup *cleanups;
+
+ SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
+ _("string"));
+
+ /* We want just fields of this type, not of base types, so instead of
+ using lookup_struct_elt_type, portions of that function are
+ copied here. */
+
+ type = tyscm_get_composite (type);
+ if (type == NULL)
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
+ _(not_composite_error));
+
+ field = gdbscm_scm_to_c_string (field_scm);
+ cleanups = make_cleanup (xfree, field);
+
+ for (i = 0; i < TYPE_NFIELDS (type); i++)
+ {
+ const char *t_field_name = TYPE_FIELD_NAME (type, i);
+
+ if (t_field_name && (strcmp_iw (t_field_name, field) == 0))
+ {
+ do_cleanups (cleanups);
+ return tyscm_make_field_smob (self, i);
+ }
+ }
+
+ do_cleanups (cleanups);
+
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, field_scm,
+ _("Unknown field"));
+}
+
+/* (type-has-field? <gdb:type> string) -> boolean
+ Return boolean indicating if type SELF has FIELD_SCM (a string). */
+
+static SCM
+gdbscm_type_has_field_p (SCM self, SCM field_scm)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+ char *field;
+ int i;
+ struct cleanup *cleanups;
+
+ SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
+ _("string"));
+
+ /* We want just fields of this type, not of base types, so instead of
+ using lookup_struct_elt_type, portions of that function are
+ copied here. */
+
+ type = tyscm_get_composite (type);
+ if (type == NULL)
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
+ _(not_composite_error));
+
+ field = gdbscm_scm_to_c_string (field_scm);
+ cleanups = make_cleanup (xfree, field);
+
+ for (i = 0; i < TYPE_NFIELDS (type); i++)
+ {
+ const char *t_field_name = TYPE_FIELD_NAME (type, i);
+
+ if (t_field_name && (strcmp_iw (t_field_name, field) == 0))
+ {
+ do_cleanups (cleanups);
+ return SCM_BOOL_T;
+ }
+ }
+
+ do_cleanups (cleanups);
+
+ return SCM_BOOL_F;
+}
+
+/* (make-field-iterator <gdb:type>) -> <gdb:iterator>
+ Make a field iterator object. */
+
+static SCM
+gdbscm_make_field_iterator (SCM self)
+{
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct type *type = t_smob->type;
+ struct type *containing_type;
+ SCM containing_type_scm;
+
+ containing_type = tyscm_get_composite (type);
+ if (containing_type == NULL)
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
+ _(not_composite_error));
+
+ /* If SELF is a typedef or reference, we want the underlying type,
+ which is what tyscm_get_composite returns. */
+ if (containing_type == type)
+ containing_type_scm = self;
+ else
+ containing_type_scm = tyscm_scm_from_type (containing_type);
+
+ return gdbscm_make_iterator (containing_type_scm, scm_from_int (0),
+ tyscm_next_field_x_proc);
+}
+
+/* (type-next-field! <gdb:iterator>) -> <gdb:field>
+ Return the next field in the iteration through the list of fields of the
+ type, or (end-of-iteration).
+ SELF is a <gdb:iterator> object created by gdbscm_make_field_iterator.
+ This is the next! <gdb:iterator> function, not exported to the user. */
+
+static SCM
+gdbscm_type_next_field_x (SCM self)
+{
+ iterator_smob *i_smob;
+ type_smob *t_smob;
+ struct type *type;
+ SCM it_scm, result, progress, object;
+ int field, rc;
+
+ it_scm = itscm_get_iterator_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ i_smob = (iterator_smob *) SCM_SMOB_DATA (it_scm);
+ object = itscm_iterator_smob_object (i_smob);
+ progress = itscm_iterator_smob_progress (i_smob);
+
+ SCM_ASSERT_TYPE (tyscm_is_type (object), object,
+ SCM_ARG1, FUNC_NAME, type_smob_name);
+ t_smob = (type_smob *) SCM_SMOB_DATA (object);
+ type = t_smob->type;
+
+ SCM_ASSERT_TYPE (scm_is_signed_integer (progress,
+ 0, TYPE_NFIELDS (type)),
+ progress, SCM_ARG1, FUNC_NAME, _("integer"));
+ field = scm_to_int (progress);
+
+ if (field < TYPE_NFIELDS (type))
+ {
+ result = tyscm_make_field_smob (object, field);
+ itscm_set_iterator_smob_progress_x (i_smob, scm_from_int (field + 1));
+ return result;
+ }
+
+ return gdbscm_end_of_iteration ();
+}
+\f
+/* Field smob accessors. */
+
+/* (field-name <gdb:field>) -> string
+ Return the name of this field or #f if there isn't one. */
+
+static SCM
+gdbscm_field_name (SCM self)
+{
+ field_smob *f_smob
+ = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct field *field = tyscm_field_smob_to_field (f_smob);
+
+ if (FIELD_NAME (*field))
+ return gdbscm_scm_from_c_string (FIELD_NAME (*field));
+ return SCM_BOOL_F;
+}
+
+/* (field-type <gdb:field>) -> <gdb:type>
+ Return the <gdb:type> object of the field or #f if there isn't one. */
+
+static SCM
+gdbscm_field_type (SCM self)
+{
+ field_smob *f_smob
+ = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct field *field = tyscm_field_smob_to_field (f_smob);
+
+ /* A field can have a NULL type in some situations. */
+ if (FIELD_TYPE (*field))
+ return tyscm_scm_from_type (FIELD_TYPE (*field));
+ return SCM_BOOL_F;
+}
+
+/* (field-enumval <gdb:field>) -> integer
+ For enum values, return its value as an integer. */
+
+static SCM
+gdbscm_field_enumval (SCM self)
+{
+ field_smob *f_smob
+ = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct field *field = tyscm_field_smob_to_field (f_smob);
+ struct type *type = tyscm_field_smob_containing_type (f_smob);
+
+ SCM_ASSERT_TYPE (TYPE_CODE (type) == TYPE_CODE_ENUM,
+ self, SCM_ARG1, FUNC_NAME, _("enum type"));
+
+ return scm_from_long (FIELD_ENUMVAL (*field));
+}
+
+/* (field-bitpos <gdb:field>) -> integer
+ For bitfields, return its offset in bits. */
+
+static SCM
+gdbscm_field_bitpos (SCM self)
+{
+ field_smob *f_smob
+ = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct field *field = tyscm_field_smob_to_field (f_smob);
+ struct type *type = tyscm_field_smob_containing_type (f_smob);
+
+ SCM_ASSERT_TYPE (TYPE_CODE (type) != TYPE_CODE_ENUM,
+ self, SCM_ARG1, FUNC_NAME, _("non-enum type"));
+
+ return scm_from_long (FIELD_BITPOS (*field));
+}
+
+/* (field-bitsize <gdb:field>) -> integer
+ Return the size of the field in bits. */
+
+static SCM
+gdbscm_field_bitsize (SCM self)
+{
+ field_smob *f_smob
+ = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct field *field = tyscm_field_smob_to_field (f_smob);
+
+ return scm_from_long (FIELD_BITPOS (*field));
+}
+
+/* (field-artificial? <gdb:field>) -> boolean
+ Return #t if field is artificial. */
+
+static SCM
+gdbscm_field_artificial_p (SCM self)
+{
+ field_smob *f_smob
+ = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct field *field = tyscm_field_smob_to_field (f_smob);
+
+ return scm_from_bool (FIELD_ARTIFICIAL (*field));
+}
+
+/* (field-baseclass? <gdb:field>) -> boolean
+ Return #t if field is a baseclass. */
+
+static SCM
+gdbscm_field_baseclass_p (SCM self)
+{
+ field_smob *f_smob
+ = tyscm_get_field_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct field *field = tyscm_field_smob_to_field (f_smob);
+ struct type *type = tyscm_field_smob_containing_type (f_smob);
+
+ if (TYPE_CODE (type) == TYPE_CODE_CLASS)
+ return scm_from_bool (f_smob->field_num < TYPE_N_BASECLASSES (type));
+ return SCM_BOOL_F;
+}
+\f
+/* Return the type named TYPE_NAME in BLOCK.
+ Returns NULL if not found.
+ This routine does not throw an error. */
+
+static struct type *
+tyscm_lookup_typename (const char *type_name, const struct block *block)
+{
+ struct type *type = NULL;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (!strncmp (type_name, "struct ", 7))
+ type = lookup_struct (type_name + 7, NULL);
+ else if (!strncmp (type_name, "union ", 6))
+ type = lookup_union (type_name + 6, NULL);
+ else if (!strncmp (type_name, "enum ", 5))
+ type = lookup_enum (type_name + 5, NULL);
+ else
+ type = lookup_typename (current_language, get_current_arch (),
+ type_name, block, 0);
+ }
+ if (except.reason < 0)
+ return NULL;
+
+ return type;
+}
+
+/* (lookup-type name [#:block <gdb:block>]) -> <gdb:type>
+ TODO: legacy template support left out until needed. */
+
+static SCM
+gdbscm_lookup_type (SCM name_scm, SCM rest)
+{
+ SCM keywords[] = { block_keyword, SCM_BOOL_F };
+ char *name;
+ SCM block_scm = SCM_BOOL_F;
+ int block_arg_pos = -1;
+ const struct block *block = NULL;
+ struct type *type;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#O",
+ name_scm, &name,
+ rest, &block_arg_pos, &block_scm);
+
+ if (block_arg_pos != -1)
+ {
+ SCM exception;
+
+ block = bkscm_scm_to_block (block_scm, block_arg_pos, FUNC_NAME,
+ &exception);
+ if (block == NULL)
+ {
+ xfree (name);
+ gdbscm_throw (exception);
+ }
+ }
+ type = tyscm_lookup_typename (name, block);
+ xfree (name);
+
+ if (type != NULL)
+ return tyscm_scm_from_type (type);
+ return SCM_BOOL_F;
+}
+\f
+/* Initialize the Scheme type code. */
+
+
+static const scheme_integer_constant type_integer_constants[] =
+{
+#define X(SYM) { #SYM, SYM }
+ X (TYPE_CODE_BITSTRING),
+ X (TYPE_CODE_PTR),
+ X (TYPE_CODE_ARRAY),
+ X (TYPE_CODE_STRUCT),
+ X (TYPE_CODE_UNION),
+ X (TYPE_CODE_ENUM),
+ X (TYPE_CODE_FLAGS),
+ X (TYPE_CODE_FUNC),
+ X (TYPE_CODE_INT),
+ X (TYPE_CODE_FLT),
+ X (TYPE_CODE_VOID),
+ X (TYPE_CODE_SET),
+ X (TYPE_CODE_RANGE),
+ X (TYPE_CODE_STRING),
+ X (TYPE_CODE_ERROR),
+ X (TYPE_CODE_METHOD),
+ X (TYPE_CODE_METHODPTR),
+ X (TYPE_CODE_MEMBERPTR),
+ X (TYPE_CODE_REF),
+ X (TYPE_CODE_CHAR),
+ X (TYPE_CODE_BOOL),
+ X (TYPE_CODE_COMPLEX),
+ X (TYPE_CODE_TYPEDEF),
+ X (TYPE_CODE_NAMESPACE),
+ X (TYPE_CODE_DECFLOAT),
+ X (TYPE_CODE_INTERNAL_FUNCTION),
+#undef X
+
+ END_INTEGER_CONSTANTS
+};
+
+static const scheme_function type_functions[] =
+{
+ { "type?", 1, 0, 0, gdbscm_type_p,
+ "\
+Return #t if the object is a <gdb:type> object." },
+
+ { "lookup-type", 1, 0, 1, gdbscm_lookup_type,
+ "\
+Return the <gdb:type> object representing string or #f if not found.\n\
+If block is given then the type is looked for in that block.\n\
+\n\
+ Arguments: string [#:block <gdb:block>]" },
+
+ { "type-code", 1, 0, 0, gdbscm_type_code,
+ "\
+Return the code of the type" },
+
+ { "type-tag", 1, 0, 0, gdbscm_type_tag,
+ "\
+Return the tag name of the type, or #f if there isn't one." },
+
+ { "type-name", 1, 0, 0, gdbscm_type_name,
+ "\
+Return the name of the type as a string, or #f if there isn't one." },
+
+ { "type-print-name", 1, 0, 0, gdbscm_type_print_name,
+ "\
+Return the print name of the type as a string." },
+
+ { "type-sizeof", 1, 0, 0, gdbscm_type_sizeof,
+ "\
+Return the size of the type, in bytes." },
+
+ { "type-strip-typedefs", 1, 0, 0, gdbscm_type_strip_typedefs,
+ "\
+Return a type formed by stripping the type of all typedefs." },
+
+ { "type-array", 2, 1, 0, gdbscm_type_array,
+ "\
+Return a type representing an array of objects of the type.\n\
+\n\
+ Arguments: <gdb:type> [low-bound] high-bound\n\
+ If low-bound is not provided zero is used.\n\
+ N.B. If only the high-bound parameter is specified, it is not\n\
+ the array size.\n\
+ Valid bounds for array indices are [low-bound,high-bound]." },
+
+ { "type-vector", 2, 1, 0, gdbscm_type_vector,
+ "\
+Return a type representing a vector of objects of the type.\n\
+Vectors differ from arrays in that if the current language has C-style\n\
+arrays, vectors don't decay to a pointer to the first element.\n\
+They are first class values.\n\
+\n\
+ Arguments: <gdb:type> [low-bound] high-bound\n\
+ If low-bound is not provided zero is used.\n\
+ N.B. If only the high-bound parameter is specified, it is not\n\
+ the array size.\n\
+ Valid bounds for array indices are [low-bound,high-bound]." },
+
+ { "type-pointer", 1, 0, 0, gdbscm_type_pointer,
+ "\
+Return a type of pointer to the type." },
+
+ { "type-range", 1, 0, 0, gdbscm_type_range,
+ "\
+Return (low high) representing the range for the type." },
+
+ { "type-reference", 1, 0, 0, gdbscm_type_reference,
+ "\
+Return a type of reference to the type." },
+
+ { "type-target", 1, 0, 0, gdbscm_type_target,
+ "\
+Return the target type of the type." },
+
+ { "type-const", 1, 0, 0, gdbscm_type_const,
+ "\
+Return a const variant of the type." },
+
+ { "type-volatile", 1, 0, 0, gdbscm_type_volatile,
+ "\
+Return a volatile variant of the type." },
+
+ { "type-unqualified", 1, 0, 0, gdbscm_type_unqualified,
+ "\
+Return a variant of the type without const or volatile attributes." },
+
+ { "type-num-fields", 1, 0, 0, gdbscm_type_num_fields,
+ "\
+Return the number of fields of the type." },
+
+ { "type-fields", 1, 0, 0, gdbscm_type_fields,
+ "\
+Return the list of <gdb:field> objects of fields of the type." },
+
+ { "make-field-iterator", 1, 0, 0, gdbscm_make_field_iterator,
+ "\
+Return a <gdb:iterator> object for iterating over the fields of the type." },
+
+ { "type-field", 2, 0, 0, gdbscm_type_field,
+ "\
+Return the field named by string of the type.\n\
+\n\
+ Arguments: <gdb:type> string" },
+
+ { "type-has-field?", 2, 0, 0, gdbscm_type_has_field_p,
+ "\
+Return #t if the type has field named string.\n\
+\n\
+ Arguments: <gdb:type> string" },
+
+ { "field?", 1, 0, 0, gdbscm_field_p,
+ "\
+Return #t if the object is a <gdb:field> object." },
+
+ { "field-name", 1, 0, 0, gdbscm_field_name,
+ "\
+Return the name of the field." },
+
+ { "field-type", 1, 0, 0, gdbscm_field_type,
+ "\
+Return the type of the field." },
+
+ { "field-enumval", 1, 0, 0, gdbscm_field_enumval,
+ "\
+Return the enum value represented by the field." },
+
+ { "field-bitpos", 1, 0, 0, gdbscm_field_bitpos,
+ "\
+Return the offset in bits of the field in its containing type." },
+
+ { "field-bitsize", 1, 0, 0, gdbscm_field_bitsize,
+ "\
+Return the size of the field in bits." },
+
+ { "field-artificial?", 1, 0, 0, gdbscm_field_artificial_p,
+ "\
+Return #t if the field is artificial." },
+
+ { "field-baseclass?", 1, 0, 0, gdbscm_field_baseclass_p,
+ "\
+Return #t if the field is a baseclass." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_types (void)
+{
+ type_smob_tag = gdbscm_make_smob_type (type_smob_name, sizeof (type_smob));
+ scm_set_smob_mark (type_smob_tag, tyscm_mark_type_smob);
+ scm_set_smob_free (type_smob_tag, tyscm_free_type_smob);
+ scm_set_smob_print (type_smob_tag, tyscm_print_type_smob);
+ scm_set_smob_equalp (type_smob_tag, tyscm_equal_p_type_smob);
+
+ field_smob_tag = gdbscm_make_smob_type (field_smob_name,
+ sizeof (field_smob));
+ scm_set_smob_mark (field_smob_tag, tyscm_mark_field_smob);
+ scm_set_smob_print (field_smob_tag, tyscm_print_field_smob);
+
+ gdbscm_define_integer_constants (type_integer_constants, 1);
+ gdbscm_define_functions (type_functions, 1);
+
+ /* This function is "private". */
+ tyscm_next_field_x_proc
+ = scm_c_define_gsubr ("%type-next-field!", 1, 0, 0,
+ gdbscm_type_next_field_x);
+ scm_set_procedure_property_x (tyscm_next_field_x_proc,
+ gdbscm_documentation_symbol,
+ gdbscm_scm_from_c_string ("\
+Internal function to assist the type fields iterator."));
+
+ block_keyword = scm_from_latin1_keyword ("block");
+
+ /* Register an objfile "free" callback so we can properly copy types
+ associated with the objfile when it's about to be deleted. */
+ tyscm_objfile_data_key
+ = register_objfile_data_with_cleanup (save_objfile_types, NULL);
+
+ global_types_map = gdbscm_create_eqable_gsmob_ptr_map (tyscm_hash_type_smob,
+ tyscm_eq_type_smob);
+}
--- /dev/null
+/* General utility routines for GDB/Scheme code.
+
+ Copyright (C) 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 <stdarg.h>
+#include <stdint.h>
+#include "gdb_assert.h"
+#include "guile-internal.h"
+
+/* Define VARIABLES in the gdb module. */
+
+void
+gdbscm_define_variables (const scheme_variable *variables, int public)
+{
+ const scheme_variable *sv;
+
+ for (sv = variables; sv->name != NULL; ++sv)
+ {
+ scm_c_define (sv->name, sv->value);
+ if (public)
+ scm_c_export (sv->name, NULL);
+ }
+}
+
+/* Define FUNCTIONS in the gdb module. */
+
+void
+gdbscm_define_functions (const scheme_function *functions, int public)
+{
+ const scheme_function *sf;
+
+ for (sf = functions; sf->name != NULL; ++sf)
+ {
+ SCM proc = scm_c_define_gsubr (sf->name, sf->required, sf->optional,
+ sf->rest, sf->func);
+
+ scm_set_procedure_property_x (proc, gdbscm_documentation_symbol,
+ gdbscm_scm_from_c_string (sf->doc_string));
+ if (public)
+ scm_c_export (sf->name, NULL);
+ }
+}
+
+/* Define CONSTANTS in the gdb module. */
+
+void
+gdbscm_define_integer_constants (const scheme_integer_constant *constants,
+ int public)
+{
+ const scheme_integer_constant *sc;
+
+ for (sc = constants; sc->name != NULL; ++sc)
+ {
+ scm_c_define (sc->name, scm_from_int (sc->value));
+ if (public)
+ scm_c_export (sc->name, NULL);
+ }
+}
+\f
+/* scm_printf, alas it doesn't exist. */
+
+void
+gdbscm_printf (SCM port, const char *format, ...)
+{
+ va_list args;
+ char *string;
+
+ va_start (args, format);
+ string = xstrvprintf (format, args);
+ va_end (args);
+ scm_puts (string, port);
+ xfree (string);
+}
+
+/* Utility for calling from gdb to "display" an SCM object. */
+
+void
+gdbscm_debug_display (SCM obj)
+{
+ SCM port = scm_current_output_port ();
+
+ scm_display (obj, port);
+ scm_newline (port);
+ scm_force_output (port);
+}
+
+/* Utility for calling from gdb to "write" an SCM object. */
+
+void
+gdbscm_debug_write (SCM obj)
+{
+ SCM port = scm_current_output_port ();
+
+ scm_write (obj, port);
+ scm_newline (port);
+ scm_force_output (port);
+}
+\f
+/* Subroutine of gdbscm_parse_function_args to simplify it.
+ Return the number of keyword arguments. */
+
+static int
+count_keywords (const SCM *keywords)
+{
+ int i;
+
+ if (keywords == NULL)
+ return 0;
+ for (i = 0; keywords[i] != SCM_BOOL_F; ++i)
+ continue;
+
+ return i;
+}
+
+/* Subroutine of gdbscm_parse_function_args to simplify it.
+ Validate an argument format string.
+ The result is a boolean indicating if "." was seen. */
+
+static int
+validate_arg_format (const char *format)
+{
+ const char *p;
+ int length = strlen (format);
+ int optional_position = -1;
+ int keyword_position = -1;
+ int dot_seen = 0;
+
+ gdb_assert (length > 0);
+
+ for (p = format; *p != '\0'; ++p)
+ {
+ switch (*p)
+ {
+ case 's':
+ case 't':
+ case 'i':
+ case 'u':
+ case 'l':
+ case 'n':
+ case 'L':
+ case 'U':
+ case 'O':
+ break;
+ case '|':
+ gdb_assert (keyword_position < 0);
+ gdb_assert (optional_position < 0);
+ optional_position = p - format;
+ break;
+ case '#':
+ gdb_assert (keyword_position < 0);
+ keyword_position = p - format;
+ break;
+ case '.':
+ gdb_assert (p[1] == '\0');
+ dot_seen = 1;
+ break;
+ default:
+ gdb_assert_not_reached ("invalid argument format character");
+ }
+ }
+
+ return dot_seen;
+}
+
+/* Our version of SCM_ASSERT_TYPE that calls gdbscm_make_type_error. */
+#define CHECK_TYPE(ok, arg, position, func_name, expected_type) \
+ do { \
+ if (!(ok)) \
+ { \
+ return gdbscm_make_type_error ((func_name), (position), (arg), \
+ (expected_type)); \
+ } \
+ } while (0)
+
+/* Subroutine of gdbscm_parse_function_args to simplify it.
+ Check the type of ARG against FORMAT_CHAR and extract the value.
+ POSITION is the position of ARG in the argument list.
+ The result is #f upon success or a <gdb:exception> object. */
+
+static SCM
+extract_arg (char format_char, SCM arg, void *argp,
+ const char *func_name, int position)
+{
+ switch (format_char)
+ {
+ case 's':
+ {
+ char **arg_ptr = argp;
+
+ CHECK_TYPE (gdbscm_is_true (scm_string_p (arg)), arg, position,
+ func_name, _("string"));
+ *arg_ptr = gdbscm_scm_to_c_string (arg);
+ break;
+ }
+ case 't':
+ {
+ int *arg_ptr = argp;
+
+ /* While in Scheme, anything non-#f is "true", we're strict. */
+ CHECK_TYPE (gdbscm_is_bool (arg), arg, position, func_name,
+ _("boolean"));
+ *arg_ptr = gdbscm_is_true (arg);
+ break;
+ }
+ case 'i':
+ {
+ int *arg_ptr = argp;
+
+ CHECK_TYPE (scm_is_signed_integer (arg, INT_MIN, INT_MAX),
+ arg, position, func_name, _("int"));
+ *arg_ptr = scm_to_int (arg);
+ break;
+ }
+ case 'u':
+ {
+ int *arg_ptr = argp;
+
+ CHECK_TYPE (scm_is_unsigned_integer (arg, 0, UINT_MAX),
+ arg, position, func_name, _("unsigned int"));
+ *arg_ptr = scm_to_uint (arg);
+ break;
+ }
+ case 'l':
+ {
+ long *arg_ptr = argp;
+
+ CHECK_TYPE (scm_is_signed_integer (arg, LONG_MIN, LONG_MAX),
+ arg, position, func_name, _("long"));
+ *arg_ptr = scm_to_long (arg);
+ break;
+ }
+ case 'n':
+ {
+ unsigned long *arg_ptr = argp;
+
+ CHECK_TYPE (scm_is_unsigned_integer (arg, 0, ULONG_MAX),
+ arg, position, func_name, _("unsigned long"));
+ *arg_ptr = scm_to_ulong (arg);
+ break;
+ }
+ case 'L':
+ {
+ LONGEST *arg_ptr = argp;
+
+ CHECK_TYPE (scm_is_signed_integer (arg, INT64_MIN, INT64_MAX),
+ arg, position, func_name, _("LONGEST"));
+ *arg_ptr = gdbscm_scm_to_longest (arg);
+ break;
+ }
+ case 'U':
+ {
+ ULONGEST *arg_ptr = argp;
+
+ CHECK_TYPE (scm_is_unsigned_integer (arg, 0, UINT64_MAX),
+ arg, position, func_name, _("ULONGEST"));
+ *arg_ptr = gdbscm_scm_to_ulongest (arg);
+ break;
+ }
+ case 'O':
+ {
+ SCM *arg_ptr = argp;
+
+ *arg_ptr = arg;
+ break;
+ }
+ default:
+ gdb_assert_not_reached ("invalid argument format character");
+ }
+
+ return SCM_BOOL_F;
+}
+
+#undef CHECK_TYPE
+
+/* Look up KEYWORD in KEYWORD_LIST.
+ The result is the index of the keyword in the list or -1 if not found. */
+
+static int
+lookup_keyword (const SCM *keyword_list, SCM keyword)
+{
+ int i = 0;
+
+ while (keyword_list[i] != SCM_BOOL_F)
+ {
+ if (scm_is_eq (keyword_list[i], keyword))
+ return i;
+ ++i;
+ }
+
+ return -1;
+}
+
+/* Utility to parse required, optional, and keyword arguments to Scheme
+ functions. Modelled on PyArg_ParseTupleAndKeywords, but no attempt is made
+ at similarity or functionality.
+ There is no result, if there's an error a Scheme exception is thrown.
+
+ Guile provides scm_c_bind_keyword_arguments, and feel free to use it.
+ This is for times when we want a bit more parsing.
+
+ BEGINNING_ARG_POS is the position of the first argument passed to this
+ routine. It should be one of the SCM_ARGn values. It could be > SCM_ARG1
+ if the caller chooses not to parse one or more required arguments.
+
+ KEYWORDS may be NULL if there are no keywords.
+
+ FORMAT:
+ s - string -> char *, malloc'd
+ t - boolean (gdb uses "t", for biT?) -> int
+ i - int
+ u - unsigned int
+ l - long
+ n - unsigned long
+ L - longest
+ U - unsigned longest
+ O - random scheme object
+ | - indicates the next set is for optional arguments
+ # - indicates the next set is for keyword arguments (must follow |)
+ . - indicates "rest" arguments are present, this character must appear last
+
+ FORMAT must match the definition from scm_c_{make,define}_gsubr.
+ Required and optional arguments appear in order in the format string.
+ Afterwards, keyword-based arguments are processed. There must be as many
+ remaining characters in the format string as their are keywords.
+ Except for "|#.", the number of characters in the format string must match
+ #required + #optional + #keywords.
+
+ The function is required to be defined in a compatible manner:
+ #required-args and #optional-arguments must match, and rest-arguments
+ must be specified if keyword args are desired, and/or regular "rest" args.
+
+ Example: For this function,
+ scm_c_define_gsubr ("execute", 2, 3, 1, foo);
+ the format string + keyword list could be any of:
+ 1) "ss|ttt#tt", { "key1", "key2", NULL }
+ 2) "ss|ttt.", { NULL }
+ 3) "ss|ttt#t.", { "key1", NULL }
+
+ For required and optional args pass the SCM of the argument, and a
+ pointer to the value to hold the parsed result (type depends on format
+ char). After that pass the SCM containing the "rest" arguments followed
+ by pointers to values to hold parsed keyword arguments, and if specified
+ a pointer to hold the remaining contents of "rest".
+
+ For keyword arguments pass two pointers: the first is a pointer to an int
+ that will contain the position of the argument in the arg list, and the
+ second will contain result of processing the argument. The int pointed
+ to by the first value should be initialized to -1. It can then be used
+ to tell whether the keyword was present.
+
+ If both keyword and rest arguments are present, the caller must pass a
+ pointer to contain the new value of rest (after keyword args have been
+ removed).
+
+ There's currently no way, that I know of, to specify default values for
+ optional arguments in C-provided functions. At the moment they're a
+ work-in-progress. The caller should test SCM_UNBNDP for each optional
+ argument. Unbound optional arguments are ignored. */
+
+void
+gdbscm_parse_function_args (const char *func_name,
+ int beginning_arg_pos,
+ const SCM *keywords,
+ const char *format, ...)
+{
+ va_list args;
+ const char *p;
+ int i, have_rest, num_keywords, length, position;
+ int have_optional = 0;
+ SCM status;
+ SCM rest = SCM_EOL;
+ /* Keep track of malloc'd strings. We need to free them upon error. */
+ VEC (char_ptr) *allocated_strings = NULL;
+ char *ptr;
+
+ have_rest = validate_arg_format (format);
+ num_keywords = count_keywords (keywords);
+
+ va_start (args, format);
+
+ p = format;
+ position = beginning_arg_pos;
+
+ /* Process required, optional arguments. */
+
+ while (*p && *p != '#' && *p != '.')
+ {
+ SCM arg;
+ void *arg_ptr;
+
+ if (*p == '|')
+ {
+ have_optional = 1;
+ ++p;
+ continue;
+ }
+
+ arg = va_arg (args, SCM);
+ if (!have_optional || !SCM_UNBNDP (arg))
+ {
+ arg_ptr = va_arg (args, void *);
+ status = extract_arg (*p, arg, arg_ptr, func_name, position);
+ if (!gdbscm_is_false (status))
+ goto fail;
+ if (*p == 's')
+ VEC_safe_push (char_ptr, allocated_strings, *(char **) arg_ptr);
+ }
+ ++p;
+ ++position;
+ }
+
+ /* Process keyword arguments. */
+
+ if (have_rest || num_keywords > 0)
+ rest = va_arg (args, SCM);
+
+ if (num_keywords > 0)
+ {
+ SCM *keyword_args = (SCM *) alloca (num_keywords * sizeof (SCM));
+ int *keyword_positions = (int *) alloca (num_keywords * sizeof (int));
+
+ gdb_assert (*p == '#');
+ ++p;
+
+ for (i = 0; i < num_keywords; ++i)
+ {
+ keyword_args[i] = SCM_UNSPECIFIED;
+ keyword_positions[i] = -1;
+ }
+
+ while (scm_is_pair (rest)
+ && scm_is_keyword (scm_car (rest)))
+ {
+ SCM keyword = scm_car (rest);
+
+ i = lookup_keyword (keywords, keyword);
+ if (i < 0)
+ {
+ status = gdbscm_make_error (scm_arg_type_key, func_name,
+ _("Unrecognized keyword: ~a"),
+ scm_list_1 (keyword), keyword);
+ goto fail;
+ }
+ if (!scm_is_pair (scm_cdr (rest)))
+ {
+ status = gdbscm_make_error
+ (scm_arg_type_key, func_name,
+ _("Missing value for keyword argument"),
+ scm_list_1 (keyword), keyword);
+ goto fail;
+ }
+ keyword_args[i] = scm_cadr (rest);
+ keyword_positions[i] = position + 1;
+ rest = scm_cddr (rest);
+ position += 2;
+ }
+
+ for (i = 0; i < num_keywords; ++i)
+ {
+ int *arg_pos_ptr = va_arg (args, int *);
+ void *arg_ptr = va_arg (args, void *);
+ SCM arg = keyword_args[i];
+
+ if (! scm_is_eq (arg, SCM_UNSPECIFIED))
+ {
+ *arg_pos_ptr = keyword_positions[i];
+ status = extract_arg (p[i], arg, arg_ptr, func_name,
+ keyword_positions[i]);
+ if (!gdbscm_is_false (status))
+ goto fail;
+ if (p[i] == 's')
+ {
+ VEC_safe_push (char_ptr, allocated_strings,
+ *(char **) arg_ptr);
+ }
+ }
+ }
+ }
+
+ /* Process "rest" arguments. */
+
+ if (have_rest)
+ {
+ if (num_keywords > 0)
+ {
+ SCM *rest_ptr = va_arg (args, SCM *);
+
+ *rest_ptr = rest;
+ }
+ }
+ else
+ {
+ if (! scm_is_null (rest))
+ {
+ status = gdbscm_make_error (scm_args_number_key, func_name,
+ _("Too many arguments"),
+ SCM_EOL, SCM_BOOL_F);
+ goto fail;
+ }
+ }
+
+ va_end (args);
+ VEC_free (char_ptr, allocated_strings);
+ return;
+
+ fail:
+ va_end (args);
+ for (i = 0; VEC_iterate (char_ptr, allocated_strings, i, ptr); ++i)
+ xfree (ptr);
+ VEC_free (char_ptr, allocated_strings);
+ gdbscm_throw (status);
+}
+\f
+/* Return longest L as a scheme object. */
+
+SCM
+gdbscm_scm_from_longest (LONGEST l)
+{
+ return scm_from_int64 (l);
+}
+
+/* Convert scheme object L to LONGEST.
+ It is an error to call this if L is not an integer in range of LONGEST.
+ (because the underlying Scheme function will thrown an exception,
+ which is not part of our contract with the caller). */
+
+LONGEST
+gdbscm_scm_to_longest (SCM l)
+{
+ return scm_to_int64 (l);
+}
+
+/* Return unsigned longest L as a scheme object. */
+
+SCM
+gdbscm_scm_from_ulongest (ULONGEST l)
+{
+ return scm_from_uint64 (l);
+}
+
+/* Convert scheme object U to ULONGEST.
+ It is an error to call this if U is not an integer in range of ULONGEST
+ (because the underlying Scheme function will thrown an exception,
+ which is not part of our contract with the caller). */
+
+ULONGEST
+gdbscm_scm_to_ulongest (SCM u)
+{
+ return scm_to_uint64 (u);
+}
+
+/* Same as scm_dynwind_free, but uses xfree. */
+
+void
+gdbscm_dynwind_xfree (void *ptr)
+{
+ scm_dynwind_unwind_handler (xfree, ptr, SCM_F_WIND_EXPLICITLY);
+}
+
+/* Return non-zero if PROC is a procedure. */
+
+int
+gdbscm_is_procedure (SCM proc)
+{
+ return gdbscm_is_true (scm_procedure_p (proc));
+}
--- /dev/null
+/* Scheme interface to values.
+
+ 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 "arch-utils.h"
+#include "charset.h"
+#include "cp-abi.h"
+#include "gdb_assert.h"
+#include "infcall.h"
+#include "symtab.h" /* Needed by language.h. */
+#include "language.h"
+#include "valprint.h"
+#include "value.h"
+#include "guile-internal.h"
+
+/* The <gdb:value> smob. */
+
+typedef struct _value_smob
+{
+ /* This always appears first. */
+ gdb_smob base;
+
+ /* Doubly linked list of values in values_in_scheme.
+ IWBN to use a chained_gdb_smob instead, which is doable, it just requires
+ a bit more casting than normal. */
+ struct _value_smob *next;
+ struct _value_smob *prev;
+
+ struct value *value;
+
+ /* These are cached here to avoid making multiple copies of them.
+ Plus computing the dynamic_type can be a bit expensive.
+ We use #f to indicate that the value doesn't exist (e.g. value doesn't
+ have an address), so we need another value to indicate that we haven't
+ computed the value yet. For this we use SCM_UNDEFINED. */
+ SCM address;
+ SCM type;
+ SCM dynamic_type;
+} value_smob;
+
+static const char value_smob_name[] = "gdb:value";
+
+/* The tag Guile knows the value smob by. */
+static scm_t_bits value_smob_tag;
+
+/* List of all values which are currently exposed to Scheme. It is
+ maintained so that when an objfile is discarded, preserve_values
+ can copy the values' types if needed. */
+static value_smob *values_in_scheme;
+
+/* Keywords used by Scheme procedures in this file. */
+static SCM type_keyword;
+static SCM encoding_keyword;
+static SCM errors_keyword;
+static SCM length_keyword;
+
+/* Possible #:errors values. */
+static SCM error_symbol;
+static SCM escape_symbol;
+static SCM substitute_symbol;
+\f
+/* Administrivia for value smobs. */
+
+/* Iterate over all the <gdb:value> objects, calling preserve_one_value on
+ each.
+ This is the extension_language_ops.preserve_values "method". */
+
+void
+gdbscm_preserve_values (const struct extension_language_defn *extlang,
+ struct objfile *objfile, htab_t copied_types)
+{
+ value_smob *iter;
+
+ for (iter = values_in_scheme; iter; iter = iter->next)
+ preserve_one_value (iter->value, objfile, copied_types);
+}
+
+/* Helper to add a value_smob to the global list. */
+
+static void
+vlscm_remember_scheme_value (value_smob *v_smob)
+{
+ v_smob->next = values_in_scheme;
+ if (v_smob->next)
+ v_smob->next->prev = v_smob;
+ v_smob->prev = NULL;
+ values_in_scheme = v_smob;
+}
+
+/* Helper to remove a value_smob from the global list. */
+
+static void
+vlscm_forget_value_smob (value_smob *v_smob)
+{
+ /* Remove SELF from the global list. */
+ if (v_smob->prev)
+ v_smob->prev->next = v_smob->next;
+ else
+ {
+ gdb_assert (values_in_scheme == v_smob);
+ values_in_scheme = v_smob->next;
+ }
+ if (v_smob->next)
+ v_smob->next->prev = v_smob->prev;
+}
+
+/* The smob "mark" function for <gdb:value>. */
+
+static SCM
+vlscm_mark_value_smob (SCM self)
+{
+ value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
+
+ scm_gc_mark (v_smob->address);
+ scm_gc_mark (v_smob->type);
+ scm_gc_mark (v_smob->dynamic_type);
+ /* Do this last. */
+ return gdbscm_mark_gsmob (&v_smob->base);
+}
+
+/* The smob "free" function for <gdb:value>. */
+
+static size_t
+vlscm_free_value_smob (SCM self)
+{
+ value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
+
+ vlscm_forget_value_smob (v_smob);
+ value_free (v_smob->value);
+
+ return 0;
+}
+
+/* The smob "print" function for <gdb:value>. */
+
+static int
+vlscm_print_value_smob (SCM self, SCM port, scm_print_state *pstate)
+{
+ value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self);
+ char *s = NULL;
+ struct value_print_options opts;
+ volatile struct gdb_exception except;
+
+ if (pstate->writingp)
+ gdbscm_printf (port, "#<%s ", value_smob_name);
+
+ get_user_print_options (&opts);
+ opts.deref_ref = 0;
+
+ /* pstate->writingp = zero if invoked by display/~A, and nonzero if
+ invoked by write/~S. What to do here may need to evolve.
+ IWBN if we could pass an argument to format that would we could use
+ instead of writingp. */
+ opts.raw = !!pstate->writingp;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct ui_file *stb = mem_fileopen ();
+ struct cleanup *old_chain = make_cleanup_ui_file_delete (stb);
+
+ common_val_print (v_smob->value, stb, 0, &opts, current_language);
+ s = ui_file_xstrdup (stb, NULL);
+
+ do_cleanups (old_chain);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (s != NULL)
+ {
+ scm_puts (s, port);
+ xfree (s);
+ }
+
+ if (pstate->writingp)
+ scm_puts (">", port);
+
+ scm_remember_upto_here_1 (self);
+
+ /* Non-zero means success. */
+ return 1;
+}
+
+/* The smob "equalp" function for <gdb:value>. */
+
+static SCM
+vlscm_equal_p_value_smob (SCM v1, SCM v2)
+{
+ const value_smob *v1_smob = (value_smob *) SCM_SMOB_DATA (v1);
+ const value_smob *v2_smob = (value_smob *) SCM_SMOB_DATA (v2);
+ int result = 0;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ result = value_equal (v1_smob->value, v2_smob->value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return scm_from_bool (result);
+}
+
+/* Low level routine to create a <gdb:value> object. */
+
+static SCM
+vlscm_make_value_smob (void)
+{
+ value_smob *v_smob = (value_smob *)
+ scm_gc_malloc (sizeof (value_smob), value_smob_name);
+ SCM v_scm;
+
+ /* These must be filled in by the caller. */
+ v_smob->value = NULL;
+ v_smob->prev = NULL;
+ v_smob->next = NULL;
+
+ /* These are lazily computed. */
+ v_smob->address = SCM_UNDEFINED;
+ v_smob->type = SCM_UNDEFINED;
+ v_smob->dynamic_type = SCM_UNDEFINED;
+
+ v_scm = scm_new_smob (value_smob_tag, (scm_t_bits) v_smob);
+ gdbscm_init_gsmob (&v_smob->base);
+
+ return v_scm;
+}
+
+/* Return non-zero if SCM is a <gdb:value> object. */
+
+int
+vlscm_is_value (SCM scm)
+{
+ return SCM_SMOB_PREDICATE (value_smob_tag, scm);
+}
+
+/* (value? object) -> boolean */
+
+static SCM
+gdbscm_value_p (SCM scm)
+{
+ return scm_from_bool (vlscm_is_value (scm));
+}
+
+/* Create a new <gdb:value> object that encapsulates VALUE.
+ The value is released from the all_values chain so its lifetime is not
+ bound to the execution of a command. */
+
+SCM
+vlscm_scm_from_value (struct value *value)
+{
+ /* N.B. It's important to not cause any side-effects until we know the
+ conversion worked. */
+ SCM v_scm = vlscm_make_value_smob ();
+ value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
+
+ v_smob->value = value;
+ release_value_or_incref (value);
+ vlscm_remember_scheme_value (v_smob);
+
+ return v_scm;
+}
+
+/* Returns the <gdb:value> object in SELF.
+ Throws an exception if SELF is not a <gdb:value> object. */
+
+static SCM
+vlscm_get_value_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM_ASSERT_TYPE (vlscm_is_value (self), self, arg_pos, func_name,
+ value_smob_name);
+
+ return self;
+}
+
+/* Returns a pointer to the value smob of SELF.
+ Throws an exception if SELF is not a <gdb:value> object. */
+
+static value_smob *
+vlscm_get_value_smob_arg_unsafe (SCM self, int arg_pos, const char *func_name)
+{
+ SCM v_scm = vlscm_get_value_arg_unsafe (self, arg_pos, func_name);
+ value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
+
+ return v_smob;
+}
+
+/* Return the value field of V_SCM, an object of type <gdb:value>.
+ This exists so that we don't have to export the struct's contents. */
+
+struct value *
+vlscm_scm_to_value (SCM v_scm)
+{
+ value_smob *v_smob;
+
+ gdb_assert (vlscm_is_value (v_scm));
+ v_smob = (value_smob *) SCM_SMOB_DATA (v_scm);
+ return v_smob->value;
+}
+\f
+/* Value methods. */
+
+/* (make-value x [#:type type]) -> <gdb:value> */
+
+static SCM
+gdbscm_make_value (SCM x, SCM rest)
+{
+ struct gdbarch *gdbarch = get_current_arch ();
+ const struct language_defn *language = current_language;
+ const SCM keywords[] = { type_keyword, SCM_BOOL_F };
+ int type_arg_pos = -1;
+ SCM type_scm = SCM_UNDEFINED;
+ SCM except_scm, result;
+ type_smob *t_smob;
+ struct type *type = NULL;
+ struct value *value;
+ struct cleanup *cleanups;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#O", rest,
+ &type_arg_pos, &type_scm);
+
+ if (type_arg_pos > 0)
+ {
+ t_smob = tyscm_get_type_smob_arg_unsafe (type_scm, type_arg_pos,
+ FUNC_NAME);
+ type = tyscm_type_smob_type (t_smob);
+ }
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ value = vlscm_convert_typed_value_from_scheme (FUNC_NAME, SCM_ARG1, x,
+ type_arg_pos, type_scm, type,
+ &except_scm,
+ gdbarch, language);
+ if (value == NULL)
+ {
+ do_cleanups (cleanups);
+ gdbscm_throw (except_scm);
+ }
+
+ result = vlscm_scm_from_value (value);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+ return result;
+}
+
+/* (make-lazy-value <gdb:type> address) -> <gdb:value> */
+
+static SCM
+gdbscm_make_lazy_value (SCM type_scm, SCM address_scm)
+{
+ type_smob *t_smob;
+ struct type *type;
+ ULONGEST address;
+ struct value *value = NULL;
+ SCM result;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ t_smob = tyscm_get_type_smob_arg_unsafe (type_scm, SCM_ARG1, FUNC_NAME);
+ type = tyscm_type_smob_type (t_smob);
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, NULL, "U",
+ address_scm, &address);
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ /* There's no (current) need to wrap this in a TRY_CATCH, but for consistency
+ and future-proofing we do. */
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ value = value_from_contents_and_address (type, NULL, address);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ result = vlscm_scm_from_value (value);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+ return result;
+}
+
+/* (value-optimized-out? <gdb:value>) -> boolean */
+
+static SCM
+gdbscm_value_optimized_out_p (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ int opt = 0;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ opt = value_optimized_out (value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return scm_from_bool (opt);
+}
+
+/* (value-address <gdb:value>) -> integer
+ Returns #f if the value doesn't have one. */
+
+static SCM
+gdbscm_value_address (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+
+ if (SCM_UNBNDP (v_smob->address))
+ {
+ struct value *res_val = NULL;
+ struct cleanup *cleanup
+ = make_cleanup_value_free_to_mark (value_mark ());
+ SCM address;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ res_val = value_addr (value);
+ }
+ if (except.reason < 0)
+ address = SCM_BOOL_F;
+ else
+ address = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanup);
+
+ if (gdbscm_is_exception (address))
+ gdbscm_throw (address);
+
+ v_smob->address = address;
+ }
+
+ return v_smob->address;
+}
+
+/* (value-dereference <gdb:value>) -> <gdb:value>
+ Given a value of a pointer type, apply the C unary * operator to it. */
+
+static SCM
+gdbscm_value_dereference (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ SCM result;
+ struct value *res_val = NULL;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ res_val = value_ind (value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ result = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value-referenced-value <gdb:value>) -> <gdb:value>
+ Given a value of a reference type, return the value referenced.
+ The difference between this function and gdbscm_value_dereference is that
+ the latter applies * unary operator to a value, which need not always
+ result in the value referenced.
+ For example, for a value which is a reference to an 'int' pointer ('int *'),
+ gdbscm_value_dereference will result in a value of type 'int' while
+ gdbscm_value_referenced_value will result in a value of type 'int *'. */
+
+static SCM
+gdbscm_value_referenced_value (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ SCM result;
+ struct value *res_val = NULL;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ switch (TYPE_CODE (check_typedef (value_type (value))))
+ {
+ case TYPE_CODE_PTR:
+ res_val = value_ind (value);
+ break;
+ case TYPE_CODE_REF:
+ res_val = coerce_ref (value);
+ break;
+ default:
+ error (_("Trying to get the referenced value from a value which is"
+ " neither a pointer nor a reference"));
+ }
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ result = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value-type <gdb:value>) -> <gdb:type> */
+
+static SCM
+gdbscm_value_type (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+
+ if (SCM_UNBNDP (v_smob->type))
+ v_smob->type = tyscm_scm_from_type (value_type (value));
+
+ return v_smob->type;
+}
+
+/* (value-dynamic-type <gdb:value>) -> <gdb:type> */
+
+static SCM
+gdbscm_value_dynamic_type (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ struct type *type = NULL;
+ volatile struct gdb_exception except;
+
+ if (! SCM_UNBNDP (v_smob->type))
+ return v_smob->dynamic_type;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct cleanup *cleanup
+ = make_cleanup_value_free_to_mark (value_mark ());
+
+ type = value_type (value);
+ CHECK_TYPEDEF (type);
+
+ if (((TYPE_CODE (type) == TYPE_CODE_PTR)
+ || (TYPE_CODE (type) == TYPE_CODE_REF))
+ && (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_CLASS))
+ {
+ struct value *target;
+ int was_pointer = TYPE_CODE (type) == TYPE_CODE_PTR;
+
+ target = value_ind (value);
+ type = value_rtti_type (target, NULL, NULL, NULL);
+
+ if (type)
+ {
+ if (was_pointer)
+ type = lookup_pointer_type (type);
+ else
+ type = lookup_reference_type (type);
+ }
+ }
+ else if (TYPE_CODE (type) == TYPE_CODE_CLASS)
+ type = value_rtti_type (value, NULL, NULL, NULL);
+ else
+ {
+ /* Re-use object's static type. */
+ type = NULL;
+ }
+
+ do_cleanups (cleanup);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (type == NULL)
+ v_smob->dynamic_type = gdbscm_value_type (self);
+ else
+ v_smob->dynamic_type = tyscm_scm_from_type (type);
+
+ return v_smob->dynamic_type;
+}
+
+/* A helper function that implements the various cast operators. */
+
+static SCM
+vlscm_do_cast (SCM self, SCM type_scm, enum exp_opcode op,
+ const char *func_name)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ type_smob *t_smob
+ = tyscm_get_type_smob_arg_unsafe (type_scm, SCM_ARG2, FUNC_NAME);
+ struct type *type = tyscm_type_smob_type (t_smob);
+ SCM result;
+ struct value *res_val = NULL;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (op == UNOP_DYNAMIC_CAST)
+ res_val = value_dynamic_cast (type, value);
+ else if (op == UNOP_REINTERPRET_CAST)
+ res_val = value_reinterpret_cast (type, value);
+ else
+ {
+ gdb_assert (op == UNOP_CAST);
+ res_val = value_cast (type, value);
+ }
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ gdb_assert (res_val != NULL);
+ result = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value-cast <gdb:value> <gdb:type>) -> <gdb:value> */
+
+static SCM
+gdbscm_value_cast (SCM self, SCM new_type)
+{
+ return vlscm_do_cast (self, new_type, UNOP_CAST, FUNC_NAME);
+}
+
+/* (value-dynamic-cast <gdb:value> <gdb:type>) -> <gdb:value> */
+
+static SCM
+gdbscm_value_dynamic_cast (SCM self, SCM new_type)
+{
+ return vlscm_do_cast (self, new_type, UNOP_DYNAMIC_CAST, FUNC_NAME);
+}
+
+/* (value-reinterpret-cast <gdb:value> <gdb:type>) -> <gdb:value> */
+
+static SCM
+gdbscm_value_reinterpret_cast (SCM self, SCM new_type)
+{
+ return vlscm_do_cast (self, new_type, UNOP_REINTERPRET_CAST, FUNC_NAME);
+}
+
+/* (value-field <gdb:value> string) -> <gdb:value>
+ Given string name of an element inside structure, return its <gdb:value>
+ object. */
+
+static SCM
+gdbscm_value_field (SCM self, SCM field_scm)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ char *field = NULL;
+ struct value *res_val = NULL;
+ SCM result;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, SCM_ARG2, FUNC_NAME,
+ _("string"));
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ field = gdbscm_scm_to_c_string (field_scm);
+ make_cleanup (xfree, field);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct value *tmp = value;
+
+ res_val = value_struct_elt (&tmp, NULL, field, NULL, NULL);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ gdb_assert (res_val != NULL);
+ result = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value-subscript <gdb:value> integer|<gdb:value>) -> <gdb:value>
+ Return the specified value in an array. */
+
+static SCM
+gdbscm_value_subscript (SCM self, SCM index_scm)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ struct value *index = NULL;
+ struct value *res_val = NULL;
+ struct type *type = value_type (value);
+ struct gdbarch *gdbarch;
+ SCM result, except_scm;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ /* The sequencing here, as everywhere else, is important.
+ We can't have existing cleanups when a Scheme exception is thrown. */
+
+ SCM_ASSERT (type != NULL, self, SCM_ARG2, FUNC_NAME);
+ gdbarch = get_type_arch (type);
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+
+ index = vlscm_convert_value_from_scheme (FUNC_NAME, SCM_ARG2, index_scm,
+ &except_scm,
+ gdbarch, current_language);
+ if (index == NULL)
+ {
+ do_cleanups (cleanups);
+ gdbscm_throw (except_scm);
+ }
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct value *tmp = value;
+
+ /* Assume we are attempting an array access, and let the value code
+ throw an exception if the index has an invalid type.
+ Check the value's type is something that can be accessed via
+ a subscript. */
+ tmp = coerce_ref (tmp);
+ type = check_typedef (value_type (tmp));
+ if (TYPE_CODE (type) != TYPE_CODE_ARRAY
+ && TYPE_CODE (type) != TYPE_CODE_PTR)
+ error (_("Cannot subscript requested type"));
+
+ res_val = value_subscript (tmp, value_as_long (index));
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ gdb_assert (res_val != NULL);
+ result = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value-call <gdb:value> arg-list) -> <gdb:value>
+ Perform an inferior function call on the value. */
+
+static SCM
+gdbscm_value_call (SCM self, SCM args)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *function = v_smob->value;
+ struct value *mark = value_mark ();
+ struct type *ftype = NULL;
+ long args_count;
+ struct value **vargs = NULL;
+ SCM result = SCM_BOOL_F;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ ftype = check_typedef (value_type (function));
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ SCM_ASSERT_TYPE (TYPE_CODE (ftype) == TYPE_CODE_FUNC, self,
+ SCM_ARG1, FUNC_NAME,
+ _("function (value of TYPE_CODE_FUNC)"));
+
+ SCM_ASSERT_TYPE (gdbscm_is_true (scm_list_p (args)), args,
+ SCM_ARG2, FUNC_NAME, _("list"));
+
+ args_count = scm_ilength (args);
+ if (args_count > 0)
+ {
+ struct gdbarch *gdbarch = get_current_arch ();
+ const struct language_defn *language = current_language;
+ SCM except_scm;
+ long i;
+
+ vargs = alloca (sizeof (struct value *) * args_count);
+ for (i = 0; i < args_count; i++)
+ {
+ SCM arg = scm_car (args);
+
+ vargs[i] = vlscm_convert_value_from_scheme (FUNC_NAME,
+ GDBSCM_ARG_NONE, arg,
+ &except_scm,
+ gdbarch, language);
+ if (vargs[i] == NULL)
+ gdbscm_throw (except_scm);
+
+ args = scm_cdr (args);
+ }
+ gdb_assert (gdbscm_is_true (scm_null_p (args)));
+ }
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct cleanup *cleanup = make_cleanup_value_free_to_mark (mark);
+ struct value *return_value;
+
+ return_value = call_function_by_hand (function, args_count, vargs);
+ result = vlscm_scm_from_value (return_value);
+ do_cleanups (cleanup);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value->bytevector <gdb:value>) -> bytevector */
+
+static SCM
+gdbscm_value_to_bytevector (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ struct type *type;
+ size_t length = 0;
+ const gdb_byte *contents = NULL;
+ SCM bv;
+ volatile struct gdb_exception except;
+
+ type = value_type (value);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ CHECK_TYPEDEF (type);
+ length = TYPE_LENGTH (type);
+ contents = value_contents (value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ bv = scm_c_make_bytevector (length);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (bv), contents, length);
+
+ return bv;
+}
+
+/* Helper function to determine if a type is "int-like". */
+
+static int
+is_intlike (struct type *type, int ptr_ok)
+{
+ return (TYPE_CODE (type) == TYPE_CODE_INT
+ || TYPE_CODE (type) == TYPE_CODE_ENUM
+ || TYPE_CODE (type) == TYPE_CODE_BOOL
+ || TYPE_CODE (type) == TYPE_CODE_CHAR
+ || (ptr_ok && TYPE_CODE (type) == TYPE_CODE_PTR));
+}
+
+/* (value->bool <gdb:value>) -> boolean
+ Throws an error if the value is not integer-like. */
+
+static SCM
+gdbscm_value_to_bool (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ struct type *type;
+ LONGEST l = 0;
+ volatile struct gdb_exception except;
+
+ type = value_type (value);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ CHECK_TYPEDEF (type);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
+ _("integer-like gdb value"));
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (TYPE_CODE (type) == TYPE_CODE_PTR)
+ l = value_as_address (value);
+ else
+ l = value_as_long (value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return scm_from_bool (l != 0);
+}
+
+/* (value->integer <gdb:value>) -> integer
+ Throws an error if the value is not integer-like. */
+
+static SCM
+gdbscm_value_to_integer (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ struct type *type;
+ LONGEST l = 0;
+ volatile struct gdb_exception except;
+
+ type = value_type (value);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ CHECK_TYPEDEF (type);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ SCM_ASSERT_TYPE (is_intlike (type, 1), self, SCM_ARG1, FUNC_NAME,
+ _("integer-like gdb value"));
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (TYPE_CODE (type) == TYPE_CODE_PTR)
+ l = value_as_address (value);
+ else
+ l = value_as_long (value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (TYPE_UNSIGNED (type))
+ return gdbscm_scm_from_ulongest (l);
+ else
+ return gdbscm_scm_from_longest (l);
+}
+
+/* (value->real <gdb:value>) -> real
+ Throws an error if the value is not a number. */
+
+static SCM
+gdbscm_value_to_real (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ struct type *type;
+ DOUBLEST d = 0;
+ volatile struct gdb_exception except;
+
+ type = value_type (value);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ CHECK_TYPEDEF (type);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ SCM_ASSERT_TYPE (is_intlike (type, 0) || TYPE_CODE (type) == TYPE_CODE_FLT,
+ self, SCM_ARG1, FUNC_NAME, _("number"));
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ d = value_as_double (value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ /* TODO: Is there a better way to check if the value fits? */
+ if (d != (double) d)
+ gdbscm_out_of_range_error (FUNC_NAME, SCM_ARG1, self,
+ _("number can't be converted to a double"));
+
+ return scm_from_double (d);
+}
+
+/* (value->string <gdb:value>
+ [#:encoding encoding]
+ [#:errors #f | 'error | 'substitute]
+ [#:length length])
+ -> string
+ Return Unicode string with value's contents, which must be a string.
+
+ If ENCODING is not given, the string is assumed to be encoded in
+ the target's charset.
+
+ ERRORS is one of #f, 'error or 'substitute.
+ An error setting of #f means use the default, which is
+ Guile's %default-port-conversion-strategy. If the default is not one
+ of 'error or 'substitute, 'substitute is used.
+ An error setting of "error" causes an exception to be thrown if there's
+ a decoding error. An error setting of "substitute" causes invalid
+ characters to be replaced with "?".
+
+ If LENGTH is provided, only fetch string to the length provided.
+ LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
+
+static SCM
+gdbscm_value_to_string (SCM self, SCM rest)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ const SCM keywords[] = {
+ encoding_keyword, errors_keyword, length_keyword, SCM_BOOL_F
+ };
+ int encoding_arg_pos = -1, errors_arg_pos = -1, length_arg_pos = -1;
+ char *encoding = NULL;
+ SCM errors = SCM_BOOL_F;
+ int length = -1;
+ gdb_byte *buffer = NULL;
+ const char *la_encoding = NULL;
+ struct type *char_type = NULL;
+ SCM result;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ /* The sequencing here, as everywhere else, is important.
+ We can't have existing cleanups when a Scheme exception is thrown. */
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#sOi", rest,
+ &encoding_arg_pos, &encoding,
+ &errors_arg_pos, &errors,
+ &length_arg_pos, &length);
+
+ cleanups = make_cleanup (xfree, encoding);
+
+ if (errors_arg_pos > 0
+ && errors != SCM_BOOL_F
+ && !scm_is_eq (errors, error_symbol)
+ && !scm_is_eq (errors, substitute_symbol))
+ {
+ SCM excp
+ = gdbscm_make_out_of_range_error (FUNC_NAME, errors_arg_pos, errors,
+ _("invalid error kind"));
+
+ do_cleanups (cleanups);
+ gdbscm_throw (excp);
+ }
+ if (errors == SCM_BOOL_F)
+ errors = scm_port_conversion_strategy (SCM_BOOL_F);
+ /* We don't assume anything about the result of scm_port_conversion_strategy.
+ From this point on, if errors is not 'errors, use 'substitute. */
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ LA_GET_STRING (value, &buffer, &length, &char_type, &la_encoding);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ /* If errors is "error" scm_from_stringn may throw a Scheme exception.
+ Make sure we don't leak. This is done via scm_dynwind_begin, et.al. */
+ discard_cleanups (cleanups);
+
+ scm_dynwind_begin (0);
+
+ gdbscm_dynwind_xfree (encoding);
+ gdbscm_dynwind_xfree (buffer);
+
+ result = scm_from_stringn ((const char *) buffer,
+ length * TYPE_LENGTH (char_type),
+ (encoding != NULL && *encoding != '\0'
+ ? encoding
+ : la_encoding),
+ scm_is_eq (errors, error_symbol)
+ ? SCM_FAILED_CONVERSION_ERROR
+ : SCM_FAILED_CONVERSION_QUESTION_MARK);
+
+ scm_dynwind_end ();
+
+ return result;
+}
+
+/* (value->lazy-string <gdb:value> [#:encoding encoding] [#:length length])
+ -> <gdb:lazy-string>
+ Return a Scheme object representing a lazy_string_object type.
+ A lazy string is a pointer to a string with an optional encoding and length.
+ If ENCODING is not given, the target's charset is used.
+ If LENGTH is provided then the length parameter is set to LENGTH, otherwise
+ length will be set to -1 (first null of appropriate with).
+ LENGTH must be a Scheme integer, it can't be a <gdb:value> integer. */
+
+static SCM
+gdbscm_value_to_lazy_string (SCM self, SCM rest)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ const SCM keywords[] = { encoding_keyword, length_keyword, SCM_BOOL_F };
+ int encoding_arg_pos = -1, length_arg_pos = -1;
+ char *encoding = NULL;
+ int length = -1;
+ SCM result = SCM_BOOL_F; /* -Wall */
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ /* The sequencing here, as everywhere else, is important.
+ We can't have existing cleanups when a Scheme exception is thrown. */
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG2, keywords, "#si", rest,
+ &encoding_arg_pos, &encoding,
+ &length_arg_pos, &length);
+
+ cleanups = make_cleanup (xfree, encoding);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct cleanup *inner_cleanup
+ = make_cleanup_value_free_to_mark (value_mark ());
+
+ if (TYPE_CODE (value_type (value)) == TYPE_CODE_PTR)
+ value = value_ind (value);
+
+ result = lsscm_make_lazy_string (value_address (value), length,
+ encoding, value_type (value));
+
+ do_cleanups (inner_cleanup);
+ }
+ do_cleanups (cleanups);
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (value-lazy? <gdb:value>) -> boolean */
+
+static SCM
+gdbscm_value_lazy_p (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+
+ return scm_from_bool (value_lazy (value));
+}
+
+/* (value-fetch-lazy! <gdb:value>) -> unspecified */
+
+static SCM
+gdbscm_value_fetch_lazy_x (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ volatile struct gdb_exception except;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ if (value_lazy (value))
+ value_fetch_lazy (value);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return SCM_UNSPECIFIED;
+}
+
+/* (value-print <gdb:value>) -> string */
+
+static SCM
+gdbscm_value_print (SCM self)
+{
+ value_smob *v_smob
+ = vlscm_get_value_smob_arg_unsafe (self, SCM_ARG1, FUNC_NAME);
+ struct value *value = v_smob->value;
+ struct value_print_options opts;
+ char *s = NULL;
+ SCM result;
+ volatile struct gdb_exception except;
+
+ get_user_print_options (&opts);
+ opts.deref_ref = 0;
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ struct ui_file *stb = mem_fileopen ();
+ struct cleanup *old_chain = make_cleanup_ui_file_delete (stb);
+
+ common_val_print (value, stb, 0, &opts, current_language);
+ s = ui_file_xstrdup (stb, NULL);
+
+ do_cleanups (old_chain);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ /* Use SCM_FAILED_CONVERSION_QUESTION_MARK to ensure this doesn't
+ throw an error if the encoding fails.
+ IWBN to use scm_take_locale_string here, but we'd have to temporarily
+ override the default port conversion handler because contrary to
+ documentation it doesn't necessarily free the input string. */
+ result = scm_from_stringn (s, strlen (s), host_charset (),
+ SCM_FAILED_CONVERSION_QUESTION_MARK);
+ xfree (s);
+
+ return result;
+}
+\f
+/* (parse-and-eval string) -> <gdb:value>
+ Parse a string and evaluate the string as an expression. */
+
+static SCM
+gdbscm_parse_and_eval (SCM expr_scm)
+{
+ char *expr_str;
+ struct value *res_val = NULL;
+ SCM result;
+ struct cleanup *cleanups;
+ volatile struct gdb_exception except;
+
+ /* The sequencing here, as everywhere else, is important.
+ We can't have existing cleanups when a Scheme exception is thrown. */
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "s",
+ expr_scm, &expr_str);
+
+ cleanups = make_cleanup_value_free_to_mark (value_mark ());
+ make_cleanup (xfree, expr_str);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ res_val = parse_and_eval (expr_str);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS (except, cleanups);
+
+ gdb_assert (res_val != NULL);
+ result = vlscm_scm_from_value (res_val);
+
+ do_cleanups (cleanups);
+
+ if (gdbscm_is_exception (result))
+ gdbscm_throw (result);
+
+ return result;
+}
+
+/* (history-ref integer) -> <gdb:value>
+ Return the specified value from GDB's value history. */
+
+static SCM
+gdbscm_history_ref (SCM index)
+{
+ int i;
+ struct value *res_val = NULL; /* Initialize to appease gcc warning. */
+ volatile struct gdb_exception except;
+
+ gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, NULL, "i", index, &i);
+
+ TRY_CATCH (except, RETURN_MASK_ALL)
+ {
+ res_val = access_value_history (i);
+ }
+ GDBSCM_HANDLE_GDB_EXCEPTION (except);
+
+ return vlscm_scm_from_value (res_val);
+}
+\f
+/* Initialize the Scheme value code. */
+
+static const scheme_function value_functions[] =
+{
+ { "value?", 1, 0, 0, gdbscm_value_p,
+ "\
+Return #t if the object is a <gdb:value> object." },
+
+ { "make-value", 1, 0, 1, gdbscm_make_value,
+ "\
+Create a <gdb:value> representing object.\n\
+Typically this is used to convert numbers and strings to\n\
+<gdb:value> objects.\n\
+\n\
+ Arguments: object [#:type <gdb:type>]" },
+
+ { "value-optimized-out?", 1, 0, 0, gdbscm_value_optimized_out_p,
+ "\
+Return #t if the value has been optimizd out." },
+
+ { "value-address", 1, 0, 0, gdbscm_value_address,
+ "\
+Return the address of the value." },
+
+ { "value-type", 1, 0, 0, gdbscm_value_type,
+ "\
+Return the type of the value." },
+
+ { "value-dynamic-type", 1, 0, 0, gdbscm_value_dynamic_type,
+ "\
+Return the dynamic type of the value." },
+
+ { "value-cast", 2, 0, 0, gdbscm_value_cast,
+ "\
+Cast the value to the supplied type.\n\
+\n\
+ Arguments: <gdb:value> <gdb:type>" },
+
+ { "value-dynamic-cast", 2, 0, 0, gdbscm_value_dynamic_cast,
+ "\
+Cast the value to the supplied type, as if by the C++\n\
+dynamic_cast operator.\n\
+\n\
+ Arguments: <gdb:value> <gdb:type>" },
+
+ { "value-reinterpret-cast", 2, 0, 0, gdbscm_value_reinterpret_cast,
+ "\
+Cast the value to the supplied type, as if by the C++\n\
+reinterpret_cast operator.\n\
+\n\
+ Arguments: <gdb:value> <gdb:type>" },
+
+ { "value-dereference", 1, 0, 0, gdbscm_value_dereference,
+ "\
+Return the result of applying the C unary * operator to the value." },
+
+ { "value-referenced-value", 1, 0, 0, gdbscm_value_referenced_value,
+ "\
+Given a value of a reference type, return the value referenced.\n\
+The difference between this function and value-dereference is that\n\
+the latter applies * unary operator to a value, which need not always\n\
+result in the value referenced.\n\
+For example, for a value which is a reference to an 'int' pointer ('int *'),\n\
+value-dereference will result in a value of type 'int' while\n\
+value-referenced-value will result in a value of type 'int *'." },
+
+ { "value-field", 2, 0, 0, gdbscm_value_field,
+ "\
+Return the specified field of the value.\n\
+\n\
+ Arguments: <gdb:value> string" },
+
+ { "value-subscript", 2, 0, 0, gdbscm_value_subscript,
+ "\
+Return the value of the array at the specified index.\n\
+\n\
+ Arguments: <gdb:value> integer" },
+
+ { "value-call", 2, 0, 0, gdbscm_value_call,
+ "\
+Perform an inferior function call taking the value as a pointer to the\n\
+function to call.\n\
+Each element of the argument list must be a <gdb:value> object or an object\n\
+that can be converted to one.\n\
+The result is the value returned by the function.\n\
+\n\
+ Arguments: <gdb:value> arg-list" },
+
+ { "value->bool", 1, 0, 0, gdbscm_value_to_bool,
+ "\
+Return the Scheme boolean representing the GDB value.\n\
+The value must be \"integer like\". Pointers are ok." },
+
+ { "value->integer", 1, 0, 0, gdbscm_value_to_integer,
+ "\
+Return the Scheme integer representing the GDB value.\n\
+The value must be \"integer like\". Pointers are ok." },
+
+ { "value->real", 1, 0, 0, gdbscm_value_to_real,
+ "\
+Return the Scheme real number representing the GDB value.\n\
+The value must be a number." },
+
+ { "value->bytevector", 1, 0, 0, gdbscm_value_to_bytevector,
+ "\
+Return a Scheme bytevector with the raw contents of the GDB value.\n\
+No transformation, endian or otherwise, is performed." },
+
+ { "value->string", 1, 0, 1, gdbscm_value_to_string,
+ "\
+Return the Unicode string of the value's contents.\n\
+If ENCODING is not given, the string is assumed to be encoded in\n\
+the target's charset.\n\
+An error setting \"error\" causes an exception to be thrown if there's\n\
+a decoding error. An error setting of \"substitute\" causes invalid\n\
+characters to be replaced with \"?\". The default is \"error\".\n\
+If LENGTH is provided, only fetch string to the length provided.\n\
+\n\
+ Arguments: <gdb:value>\n\
+ [#:encoding encoding] [#:errors \"error\"|\"substitute\"]\n\
+ [#:length length]" },
+
+ { "value->lazy-string", 1, 0, 1, gdbscm_value_to_lazy_string,
+ "\
+Return a Scheme object representing a lazily fetched Unicode string\n\
+of the value's contents.\n\
+If ENCODING is not given, the string is assumed to be encoded in\n\
+the target's charset.\n\
+If LENGTH is provided, only fetch string to the length provided.\n\
+\n\
+ Arguments: <gdb:value> [#:encoding encoding] [#:length length]" },
+
+ { "value-lazy?", 1, 0, 0, gdbscm_value_lazy_p,
+ "\
+Return #t if the value is lazy (not fetched yet from the inferior).\n\
+A lazy value is fetched when needed, or when the value-fetch-lazy! function\n\
+is called." },
+
+ { "make-lazy-value", 2, 0, 0, gdbscm_make_lazy_value,
+ "\
+Create a <gdb:value> that will be lazily fetched from the target.\n\
+\n\
+ Arguments: <gdb:type> address" },
+
+ { "value-fetch-lazy!", 1, 0, 0, gdbscm_value_fetch_lazy_x,
+ "\
+Fetch the value from the inferior, if it was lazy.\n\
+The result is \"unspecified\"." },
+
+ { "value-print", 1, 0, 0, gdbscm_value_print,
+ "\
+Return the string representation (print form) of the value." },
+
+ { "parse-and-eval", 1, 0, 0, gdbscm_parse_and_eval,
+ "\
+Evaluates string in gdb and returns the result as a <gdb:value> object." },
+
+ { "history-ref", 1, 0, 0, gdbscm_history_ref,
+ "\
+Return the specified value from GDB's value history." },
+
+ END_FUNCTIONS
+};
+
+void
+gdbscm_initialize_values (void)
+{
+ value_smob_tag = gdbscm_make_smob_type (value_smob_name,
+ sizeof (value_smob));
+ scm_set_smob_mark (value_smob_tag, vlscm_mark_value_smob);
+ scm_set_smob_free (value_smob_tag, vlscm_free_value_smob);
+ scm_set_smob_print (value_smob_tag, vlscm_print_value_smob);
+ scm_set_smob_equalp (value_smob_tag, vlscm_equal_p_value_smob);
+
+ gdbscm_define_functions (value_functions, 1);
+
+ type_keyword = scm_from_latin1_keyword ("type");
+ encoding_keyword = scm_from_latin1_keyword ("encoding");
+ errors_keyword = scm_from_latin1_keyword ("errors");
+ length_keyword = scm_from_latin1_keyword ("length");
+
+ error_symbol = scm_from_latin1_symbol ("error");
+ escape_symbol = scm_from_latin1_symbol ("escape");
+ substitute_symbol = scm_from_latin1_symbol ("substitute");
+}
+2014-02-10 Doug Evans <xdje42@gmail.com>
+
+ * configure.ac (AC_OUTPUT): Add gdb.guile.
+ * configure: Regenerate.
+ * lib/gdb-guile.exp: New file.
+ * lib/gdb.exp (get_target_charset): New function.
+ * gdb.base/help.exp: Update expected output from "apropos apropos".
+ * gdb.guile/Makefile.in: New file.
+ * gdb.guile/guile.exp: New file.
+ * gdb.guile/scm-arch.c: New file.
+ * gdb.guile/scm-arch.exp: New file.
+ * gdb.guile/scm-block.c: New file.
+ * gdb.guile/scm-block.exp: New file.
+ * gdb.guile/scm-breakpoint.c: New file.
+ * gdb.guile/scm-breakpoint.exp: New file.
+ * gdb.guile/scm-disasm.c: New file.
+ * gdb.guile/scm-disasm.exp: New file.
+ * gdb.guile/scm-equal.c: New file.
+ * gdb.guile/scm-equal.exp: New file.
+ * gdb.guile/scm-error.exp: New file.
+ * gdb.guile/scm-error.scm: New file.
+ * gdb.guile/scm-frame-args.c: New file.
+ * gdb.guile/scm-frame-args.exp: New file.
+ * gdb.guile/scm-frame-args.scm: New file.
+ * gdb.guile/scm-frame-inline.c: New file.
+ * gdb.guile/scm-frame-inline.exp: New file.
+ * gdb.guile/scm-frame.c: New file.
+ * gdb.guile/scm-frame.exp: New file.
+ * gdb.guile/scm-generics.exp: New file.
+ * gdb.guile/scm-gsmob.exp: New file.
+ * gdb.guile/scm-iterator.c: New file.
+ * gdb.guile/scm-iterator.exp: New file.
+ * gdb.guile/scm-math.c: New file.
+ * gdb.guile/scm-math.exp: New file.
+ * gdb.guile/scm-objfile-script-gdb.in: New file.
+ * gdb.guile/scm-objfile-script.c: New file.
+ * gdb.guile/scm-objfile-script.exp: New file.
+ * gdb.guile/scm-objfile.c: New file.
+ * gdb.guile/scm-objfile.exp: New file.
+ * gdb.guile/scm-ports.exp: New file.
+ * gdb.guile/scm-pretty-print.c: New file.
+ * gdb.guile/scm-pretty-print.exp: New file.
+ * gdb.guile/scm-pretty-print.scm: New file.
+ * gdb.guile/scm-section-script.c: New file.
+ * gdb.guile/scm-section-script.exp: New file.
+ * gdb.guile/scm-section-script.scm: New file.
+ * gdb.guile/scm-symbol.c: New file.
+ * gdb.guile/scm-symbol.exp: New file.
+ * gdb.guile/scm-symtab-2.c: New file.
+ * gdb.guile/scm-symtab.c: New file.
+ * gdb.guile/scm-symtab.exp: New file.
+ * gdb.guile/scm-type.c: New file.
+ * gdb.guile/scm-type.exp: New file.
+ * gdb.guile/scm-value-cc.cc: New file.
+ * gdb.guile/scm-value-cc.exp: New file.
+ * gdb.guile/scm-value.c: New file.
+ * gdb.guile/scm-value.exp: New file.
+ * gdb.guile/source2.scm: New file.
+ * gdb.guile/types-module.cc: New file.
+ * gdb.guile/types-module.exp: New file.
+
2014-02-10 Yao Qi <yao@codesourcery.com>
PR testsuite/16543
-ac_config_files="$ac_config_files Makefile gdb.ada/Makefile gdb.arch/Makefile gdb.asm/Makefile gdb.base/Makefile gdb.btrace/Makefile gdb.cell/Makefile gdb.cp/Makefile gdb.disasm/Makefile gdb.dwarf2/Makefile gdb.dlang/Makefile gdb.fortran/Makefile gdb.gdb/Makefile gdb.go/Makefile gdb.server/Makefile gdb.java/Makefile gdb.hp/Makefile gdb.hp/gdb.objdbg/Makefile gdb.hp/gdb.base-hp/Makefile gdb.hp/gdb.aCC/Makefile gdb.hp/gdb.compat/Makefile gdb.hp/gdb.defects/Makefile gdb.linespec/Makefile gdb.mi/Makefile gdb.modula2/Makefile gdb.multi/Makefile gdb.objc/Makefile gdb.opencl/Makefile gdb.opt/Makefile gdb.pascal/Makefile gdb.perf/Makefile gdb.python/Makefile gdb.reverse/Makefile gdb.stabs/Makefile gdb.threads/Makefile gdb.trace/Makefile gdb.xml/Makefile"
+ac_config_files="$ac_config_files Makefile gdb.ada/Makefile gdb.arch/Makefile gdb.asm/Makefile gdb.base/Makefile gdb.btrace/Makefile gdb.cell/Makefile gdb.cp/Makefile gdb.disasm/Makefile gdb.dwarf2/Makefile gdb.dlang/Makefile gdb.fortran/Makefile gdb.gdb/Makefile gdb.go/Makefile gdb.server/Makefile gdb.java/Makefile gdb.hp/Makefile gdb.hp/gdb.objdbg/Makefile gdb.hp/gdb.base-hp/Makefile gdb.hp/gdb.aCC/Makefile gdb.hp/gdb.compat/Makefile gdb.hp/gdb.defects/Makefile gdb.guile/Makefile gdb.linespec/Makefile gdb.mi/Makefile gdb.modula2/Makefile gdb.multi/Makefile gdb.objc/Makefile gdb.opencl/Makefile gdb.opt/Makefile gdb.pascal/Makefile gdb.perf/Makefile gdb.python/Makefile gdb.reverse/Makefile gdb.stabs/Makefile gdb.threads/Makefile gdb.trace/Makefile gdb.xml/Makefile"
cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
"gdb.hp/gdb.aCC/Makefile") CONFIG_FILES="$CONFIG_FILES gdb.hp/gdb.aCC/Makefile" ;;
"gdb.hp/gdb.compat/Makefile") CONFIG_FILES="$CONFIG_FILES gdb.hp/gdb.compat/Makefile" ;;
"gdb.hp/gdb.defects/Makefile") CONFIG_FILES="$CONFIG_FILES gdb.hp/gdb.defects/Makefile" ;;
+ "gdb.guile/Makefile") CONFIG_FILES="$CONFIG_FILES gdb.guile/Makefile" ;;
"gdb.linespec/Makefile") CONFIG_FILES="$CONFIG_FILES gdb.linespec/Makefile" ;;
"gdb.mi/Makefile") CONFIG_FILES="$CONFIG_FILES gdb.mi/Makefile" ;;
"gdb.modula2/Makefile") CONFIG_FILES="$CONFIG_FILES gdb.modula2/Makefile" ;;
gdb.server/Makefile gdb.java/Makefile \
gdb.hp/Makefile gdb.hp/gdb.objdbg/Makefile gdb.hp/gdb.base-hp/Makefile \
gdb.hp/gdb.aCC/Makefile gdb.hp/gdb.compat/Makefile \
- gdb.hp/gdb.defects/Makefile gdb.linespec/Makefile \
+ gdb.hp/gdb.defects/Makefile gdb.guile/Makefile gdb.linespec/Makefile \
gdb.mi/Makefile gdb.modula2/Makefile gdb.multi/Makefile \
gdb.objc/Makefile gdb.opencl/Makefile gdb.opt/Makefile gdb.pascal/Makefile \
gdb.perf/Makefile gdb.python/Makefile gdb.reverse/Makefile gdb.stabs/Makefile \
# test apropos >1 word string
gdb_test "apropos handle signal" "handle -- Specify how to handle signals"
# test apropos apropos
-gdb_test "apropos apropos" "apropos -- Search for commands matching a REGEXP"
+gdb_test "apropos apropos" "apropos -- Search for commands matching a REGEXP.*"
--- /dev/null
+VPATH = @srcdir@
+srcdir = @srcdir@
+
+EXECUTABLES =
+
+MISCELLANEOUS =
+
+all info install-info dvi install uninstall installcheck check:
+ @echo "Nothing to be done for $@..."
+
+clean mostlyclean:
+ -rm -f *~ *.o *.ci
+ -rm -f *.dwo *.dwp
+ -rm -f core $(EXECUTABLES) $(MISCELLANEOUS)
+
+distclean maintainer-clean realclean: clean
+ -rm -f Makefile config.status config.log gdb.log gdb.sum
--- /dev/null
+# Copyright (C) 2008-2014 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"
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2014 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/>. */
+
+int
+main (void)
+{
+ return 0;
+}
--- /dev/null
+# Copyright 2014 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/>.
+
+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] {
+ return
+}
+
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" "get frame"
+gdb_scm_test_silent_cmd "guile (define arch (frame-arch frame))" "get arch"
+gdb_scm_test_silent_cmd "guile (define pc (frame-pc frame))" "get pc"
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2010-2014 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/>. */
+
+int block_func (void)
+{
+ int i = 0;
+ {
+ double i = 1.0;
+ double f = 2.0;
+ {
+ const char *i = "stuff";
+ const char *f = "foo";
+ const char *b = "bar";
+ return 0; /* Block break here. */
+ }
+ }
+}
+
+
+int main (int argc, char *argv[])
+{
+ block_func ();
+ return 0; /* Break at end. */
+}
--- /dev/null
+# Copyright (C) 2010-2014 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 exposing blocks to Guile.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
+ return -1
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+gdb_breakpoint [gdb_get_line_number "Block break here."]
+gdb_continue_to_breakpoint "Block break here."
+
+# Test initial innermost block.
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
+ "Get frame inner"
+gdb_scm_test_silent_cmd "guile (define block (frame-block frame))" \
+ "Get block inner"
+gdb_test "guile (print block)" "#<gdb:block $hex-$hex>" \
+ "Check block not #f"
+gdb_test "guile (print (block-function block))" \
+ "#f" "First anonymous block"
+gdb_test "guile (print (block-start block))" \
+ "${decimal}" "Check start not #f"
+gdb_test "guile (print (block-end block))" \
+ "${decimal}" "Check end not #f"
+
+# Test eq?.
+gdb_test "guile (print (eq? (frame-block frame) (frame-block frame)))" \
+ "= #t" "Check eq? on same block"
+gdb_test "guile (print (eq? block (block-global-block block)))" \
+ "= #f" "Check eq? on different blocks"
+
+# Test global/static blocks.
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
+ "Get frame for global/static"
+gdb_scm_test_silent_cmd "guile (define block (frame-block frame))" \
+ "Get block for global/static"
+gdb_test "guile (print (block-global? block))" \
+ "#f" "Not a global block"
+gdb_test "guile (print (block-static? block))" \
+ "#f" "Not a static block"
+gdb_scm_test_silent_cmd "guile (define gblock (block-global-block block))" \
+ "Get global block"
+gdb_scm_test_silent_cmd "guile (define sblock (block-static-block block))" \
+ "Get static block"
+gdb_test "guile (print (block-global? gblock))" \
+ "#t" "Is the global block"
+gdb_test "guile (print (block-static? sblock))" \
+ "#t" "Is the static block"
+
+# Move up superblock(s) until we reach function block_func.
+gdb_test_no_output "guile (set! block (block-superblock block))" \
+ "Get superblock"
+gdb_test "guile (print (block-function block))" \
+ "#f" "Second anonymous block"
+gdb_test_no_output "guile (set! block (block-superblock block))" \
+ "Get superblock 2"
+gdb_test "guile (print (block-function block))" \
+ "block_func" "Print superblock 2 function"
+
+# Switch frames, then test for main block.
+gdb_test "up" ".*"
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
+ "Get frame 2"
+gdb_scm_test_silent_cmd "guile (define block (frame-block frame))" \
+ "Get frame 2's block"
+gdb_test "guile (print block)" "#<gdb:block main $hex-$hex>" \
+ "Check Frame 2's block not #f"
+gdb_test "guile (print (block-function block))" \
+ "main" "main block"
+
+# Test block-valid?. This must always be the last test in this
+# testcase as it unloads the object file.
+delete_breakpoints
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
+ "Get frame for valid?"
+gdb_scm_test_silent_cmd "guile (define block (frame-block frame))" \
+ "Get frame block for valid?"
+gdb_test "guile (print (block-valid? block))" \
+ "#t" "Check block validity"
+gdb_unload
+gdb_test "guile (print (block-valid? block))" \
+ "#f" "Check block validity after unload"
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2010-2014 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/>. */
+
+int result = 0;
+
+int multiply (int i)
+{
+ return i * i;
+}
+
+int add (int i)
+{
+ return i + i;
+}
+
+
+int main (int argc, char *argv[])
+{
+ int foo = 5;
+ int bar = 42;
+ int i;
+
+ for (i = 0; i < 10; i++)
+ {
+ result += multiply (foo); /* Break at multiply. */
+ result += add (bar); /* Break at add. */
+ }
+
+ return 0; /* Break at end. */
+}
--- /dev/null
+# Copyright (C) 2010-2014 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 exposing breakpoints to Guile.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
+ return -1
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+proc test_bkpt_basic { } {
+ global srcfile testfile hex decimal
+
+ with_test_prefix "test_bkpt_basic" {
+ # Start with a fresh gdb.
+ clean_restart ${testfile}
+
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ # Initially there should be one breakpoint: main.
+
+ gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
+ "get breakpoint list 1"
+ gdb_test "guile (print (car blist))" \
+ "<gdb:breakpoint #1 BP_BREAKPOINT enabled noisy hit:1 ignore:0 @main>" \
+ "check main breakpoint"
+ gdb_test "guile (print (breakpoint-location (car blist)))" \
+ "main" "check main breakpoint location"
+
+ set mult_line [gdb_get_line_number "Break at multiply."]
+ gdb_breakpoint ${mult_line}
+ gdb_continue_to_breakpoint "Break at multiply."
+
+ # Check that the Guile breakpoint code noted the addition of a
+ # breakpoint "behind the scenes".
+ gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
+ "get breakpoint list 2"
+ gdb_scm_test_silent_cmd "guile (define mult-bkpt (cadr blist))" \
+ "get multiply breakpoint"
+ gdb_test "guile (print (length blist))" \
+ "= 2" "check for two breakpoints"
+ gdb_test "guile (print mult-bkpt)" \
+ "= #<gdb:breakpoint #2 BP_BREAKPOINT enabled noisy hit:1 ignore:0 @.*scm-breakpoint.c:$mult_line>" \
+ "check multiply breakpoint"
+ gdb_test "guile (print (breakpoint-location mult-bkpt))" \
+ "scm-breakpoint\.c:${mult_line}*" \
+ "check multiply breakpoint location"
+
+ # Check hit and ignore counts.
+ gdb_test "guile (print (breakpoint-hit-count mult-bkpt))" \
+ "= 1" "check multiply breakpoint hit count"
+ gdb_scm_test_silent_cmd "guile (set-breakpoint-ignore-count! mult-bkpt 4)" \
+ "set multiply breakpoint ignore count"
+ gdb_continue_to_breakpoint "Break at multiply."
+ gdb_test "guile (print (breakpoint-hit-count mult-bkpt))" \
+ "= 6" "check multiply breakpoint hit count 2"
+ gdb_test "print result" \
+ " = 545" "check expected variable result after 6 iterations"
+
+ # Test breakpoint is enabled and disabled correctly.
+ gdb_breakpoint [gdb_get_line_number "Break at add."]
+ gdb_continue_to_breakpoint "Break at add."
+ gdb_test "guile (print (breakpoint-enabled? mult-bkpt))" \
+ "= #t" "check multiply breakpoint enabled"
+ gdb_scm_test_silent_cmd "guile (set-breakpoint-enabled! mult-bkpt #f)" \
+ "set multiply breakpoint disabled"
+ gdb_continue_to_breakpoint "Break at add."
+ gdb_scm_test_silent_cmd "guile (set-breakpoint-enabled! mult-bkpt #t)" \
+ "set multiply breakpoint enabled"
+ gdb_continue_to_breakpoint "Break at multiply."
+
+ # Test other getters and setters.
+ gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
+ "get breakpoint list 3"
+ gdb_test "guile (print (breakpoint-thread mult-bkpt))" \
+ "= #f" "check breakpoint thread"
+ gdb_test "guile (print (= (breakpoint-type mult-bkpt) BP_BREAKPOINT))" \
+ "= #t" "check breakpoint type"
+ gdb_test "guile (print (map breakpoint-number blist))" \
+ "= \\(1 2 3\\)" "check breakpoint numbers"
+ }
+}
+
+proc test_bkpt_deletion { } {
+ global srcfile testfile hex decimal
+
+ with_test_prefix test_bkpt_deletion {
+ # Start with a fresh gdb.
+ clean_restart ${testfile}
+
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ # Test breakpoints are deleted correctly.
+ set deltst_location [gdb_get_line_number "Break at multiply."]
+ set end_location [gdb_get_line_number "Break at end."]
+ gdb_scm_test_silent_cmd "guile (define dp1 (create-breakpoint! \"$deltst_location\"))" \
+ "create deltst breakpoint"
+ gdb_breakpoint [gdb_get_line_number "Break at end."]
+ gdb_scm_test_silent_cmd "guile (define del-list (breakpoints))" \
+ "get breakpoint list 4"
+ gdb_test "guile (print (length del-list))" \
+ "= 3" "number of breakpoints before delete"
+ gdb_continue_to_breakpoint "Break at multiply." \
+ ".*/$srcfile:$deltst_location.*"
+ gdb_scm_test_silent_cmd "guile (breakpoint-delete! dp1)" \
+ "delete breakpoint"
+ gdb_test "guile (print (breakpoint-number dp1))" \
+ "ERROR: .*: Invalid object: <gdb:breakpoint> in position 1: #<gdb:breakpoint #2>.*" \
+ "check breakpoint invalidated"
+ gdb_scm_test_silent_cmd "guile (set! del-list (breakpoints))" \
+ "get breakpoint list 5"
+ gdb_test "guile (print (length del-list))" \
+ "= 2" "number of breakpoints after delete"
+ gdb_continue_to_breakpoint "Break at end." ".*/$srcfile:$end_location.*"
+ }
+}
+
+proc test_bkpt_cond_and_cmds { } {
+ global srcfile testfile hex decimal
+
+ with_test_prefix test_bkpt_cond_and_cmds {
+ # Start with a fresh gdb.
+ clean_restart ${testfile}
+
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ # Test conditional setting.
+ set bp_location1 [gdb_get_line_number "Break at multiply."]
+ gdb_scm_test_silent_cmd "guile (define bp1 (create-breakpoint! \"$bp_location1\"))" \
+ "create multiply breakpoint"
+ gdb_continue_to_breakpoint "Break at multiply."
+ gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! bp1 \"i == 5\")" \
+ "set condition"
+ gdb_test "guile (print (breakpoint-condition bp1))" \
+ "= i == 5" "test condition has been set"
+ gdb_continue_to_breakpoint "Break at multiply."
+ gdb_test "print i" \
+ "5" "test conditional breakpoint stopped after five iterations"
+ gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! bp1 #f)" \
+ "clear condition"
+ gdb_test "guile (print (breakpoint-condition bp1))" \
+ "= #f" "test condition has been removed"
+ gdb_continue_to_breakpoint "Break at multiply."
+ gdb_test "print i" "6" "test breakpoint stopped after six iterations"
+
+ # Test commands.
+ gdb_breakpoint [gdb_get_line_number "Break at add."]
+ set test {commands $bpnum}
+ gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
+ set test {print "Command for breakpoint has been executed."}
+ gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
+ set test {print result}
+ gdb_test_multiple $test $test { -re "\r\n>$" { pass $test } }
+ gdb_test "end"
+
+ gdb_scm_test_silent_cmd "guile (define blist (breakpoints))" \
+ "get breakpoint list 6"
+ gdb_test "guile (print (breakpoint-commands (list-ref blist (- (length blist) 1))))" \
+ "print \"Command for breakpoint has been executed.\".*print result"
+ }
+}
+
+proc test_bkpt_invisible { } {
+ global srcfile testfile hex decimal
+
+ with_test_prefix test_bkpt_invisible {
+ # Start with a fresh gdb.
+ clean_restart ${testfile}
+
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ # Test invisible breakpoints.
+ delete_breakpoints
+ set ibp_location [gdb_get_line_number "Break at multiply."]
+ gdb_scm_test_silent_cmd "guile (define vbp (create-breakpoint! \"$ibp_location\" #:internal #f))" \
+ "create visible breakpoint"
+ gdb_scm_test_silent_cmd "guile (define vbp (car (breakpoints)))" \
+ "get visible breakpoint"
+ gdb_test "guile (print vbp)" \
+ "= #<gdb:breakpoint #2 BP_BREAKPOINT enabled noisy hit:0 ignore:0 @.*scm-breakpoint.c:$ibp_location>" \
+ "check visible bp obj exists"
+ gdb_test "guile (print (breakpoint-location vbp))" \
+ "scm-breakpoint\.c:$ibp_location*" "check visible breakpoint location"
+ gdb_test "guile (print (breakpoint-visible? vbp))" \
+ "= #t" "check breakpoint visibility"
+ gdb_test "info breakpoints" \
+ "scm-breakpoint\.c:$ibp_location.*" \
+ "check info breakpoints shows visible breakpoints"
+ delete_breakpoints
+ gdb_scm_test_silent_cmd "guile (define ibp (create-breakpoint! \"$ibp_location\" #:internal #t))" \
+ "create invisible breakpoint"
+ gdb_test "guile (print ibp)" \
+ "= #<gdb:breakpoint #-$decimal BP_BREAKPOINT enabled noisy hit:0 ignore:0 @.*scm-breakpoint.c:$ibp_location>" \
+ "check invisible bp obj exists"
+ gdb_test "guile (print (breakpoint-location ibp))" \
+ "scm-breakpoint\.c:$ibp_location*" "check invisible breakpoint location"
+ gdb_test "guile (print (breakpoint-visible? ibp))" \
+ "= #f" "check breakpoint invisibility"
+ gdb_test "info breakpoints" \
+ "No breakpoints or watchpoints.*" \
+ "check info breakpoints does not show invisible breakpoints"
+ gdb_test "maint info breakpoints" \
+ "scm-breakpoint\.c:$ibp_location.*" \
+ "check maint info breakpoints shows invisible breakpoints"
+ }
+}
+
+proc test_watchpoints { } {
+ global srcfile testfile hex decimal
+
+ with_test_prefix test_watchpoints {
+ # Start with a fresh gdb.
+ clean_restart ${testfile}
+
+ # Disable hardware watchpoints if necessary.
+ if [target_info exists gdb,no_hardware_watchpoints] {
+ gdb_test_no_output "set can-use-hw-watchpoints 0" ""
+ }
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ gdb_scm_test_silent_cmd "guile (define wp1 (create-breakpoint! \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE))" \
+ "create watchpoint"
+ gdb_test "continue" \
+ ".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*main.*" \
+ "test watchpoint write"
+ }
+}
+
+proc test_bkpt_internal { } {
+ global srcfile testfile hex decimal
+
+ with_test_prefix test_bkpt_internal {
+ # Start with a fresh gdb.
+ clean_restart ${testfile}
+
+ # Disable hardware watchpoints if necessary.
+ if [target_info exists gdb,no_hardware_watchpoints] {
+ gdb_test_no_output "set can-use-hw-watchpoints 0" ""
+ }
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ delete_breakpoints
+
+ gdb_scm_test_silent_cmd "guile (define wp1 (create-breakpoint! \"result\" #:type BP_WATCHPOINT #:wp-class WP_WRITE #:internal #t))" \
+ "create invisible watchpoint"
+ gdb_test "info breakpoints" \
+ "No breakpoints or watchpoints.*" \
+ "check info breakpoints does not show invisible watchpoint"
+ gdb_test "maint info breakpoints" \
+ ".*watchpoint.*result.*" \
+ "check maint info breakpoints shows invisible watchpoint"
+ gdb_test "continue" \
+ ".*\[Ww\]atchpoint.*result.*Old value = 0.*New value = 25.*" \
+ "test invisible watchpoint write"
+ }
+}
+
+proc test_bkpt_eval_funcs { } {
+ global srcfile testfile hex decimal
+
+ with_test_prefix test_bkpt_eval_funcs {
+ # Start with a fresh gdb.
+ clean_restart ${testfile}
+
+ # Disable hardware watchpoints if necessary.
+ if [target_info exists gdb,no_hardware_watchpoints] {
+ gdb_test_no_output "set can-use-hw-watchpoints 0" ""
+ }
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ delete_breakpoints
+
+ gdb_test_multiline "data collection breakpoint 1" \
+ "guile" "" \
+ "(define (make-bp-data) (cons 0 0))" "" \
+ "(define bp-data-count car)" "" \
+ "(define set-bp-data-count! set-car!)" "" \
+ "(define bp-data-inf-i cdr)" "" \
+ "(define set-bp-data-inf-i! set-cdr!)" "" \
+ "(define (bp-eval-count bkpt) (bp-data-count (gsmob-property bkpt 'bp-data)))" "" \
+ "(define (bp-eval-inf-i bkpt) (bp-data-inf-i (gsmob-property bkpt 'bp-data)))" "" \
+ "(define (make-bp-eval location)" "" \
+ " (let ((bp (create-breakpoint! location)))" "" \
+ " (set-gsmob-property! bp 'bp-data (make-bp-data))" "" \
+ " (set-breakpoint-stop! bp" "" \
+ " (lambda (bkpt)" "" \
+ " (let ((data (gsmob-property bkpt 'bp-data))" "" \
+ " (inf-i (parse-and-eval \"i\")))" "" \
+ " (set-bp-data-count! data (+ (bp-data-count data) 1))" "" \
+ " (set-bp-data-inf-i! data inf-i)" "" \
+ " (value=? inf-i 3))))" "" \
+ " bp))" "" \
+ "end" ""
+
+ gdb_test_multiline "data collection breakpoint 2" \
+ "guile" "" \
+ "(define (make-bp-also-eval location)" "" \
+ " (let ((bp (create-breakpoint! location)))" "" \
+ " (set-gsmob-property! bp 'bp-data (make-bp-data))" "" \
+ " (set-breakpoint-stop! bp" "" \
+ " (lambda (bkpt)" "" \
+ " (let* ((data (gsmob-property bkpt 'bp-data))" "" \
+ " (count (+ (bp-data-count data) 1)))" "" \
+ " (set-bp-data-count! data count)" "" \
+ " (= count 9))))" "" \
+ " bp))" "" \
+ "end" ""
+
+ gdb_test_multiline "data collection breakpoint 3" \
+ "guile" "" \
+ "(define (make-bp-basic location)" "" \
+ " (let ((bp (create-breakpoint! location)))" "" \
+ " (set-gsmob-property! bp 'bp-data (make-bp-data))" "" \
+ " bp))" "" \
+ "end" ""
+
+ set bp_location2 [gdb_get_line_number "Break at multiply."]
+ set end_location [gdb_get_line_number "Break at end."]
+ gdb_scm_test_silent_cmd "guile (define eval-bp1 (make-bp-eval \"$bp_location2\"))" \
+ "create eval-bp1 breakpoint"
+ gdb_scm_test_silent_cmd "guile (define also-eval-bp1 (make-bp-also-eval \"$bp_location2\"))" \
+ "create also-eval-bp1 breakpoint"
+ gdb_scm_test_silent_cmd "guile (define never-eval-bp1 (make-bp-also-eval \"$end_location\"))" \
+ "create never-eval-bp1 breakpoint"
+ gdb_continue_to_breakpoint "Break at multiply." ".*/$srcfile:$bp_location2.*"
+ gdb_test "print i" "3" "check inferior value matches guile accounting"
+ gdb_test "guile (print (bp-eval-inf-i eval-bp1))" \
+ "= 3" "check guile accounting matches inferior"
+ gdb_test "guile (print (bp-eval-count also-eval-bp1))" \
+ "= 4" \
+ "check non firing same-location breakpoint eval function was also called at each stop 1"
+ gdb_test "guile (print (bp-eval-count eval-bp1))" \
+ "= 4" \
+ "check non firing same-location breakpoint eval function was also called at each stop 2"
+
+ # Check we cannot assign a condition to a breakpoint with a stop-func,
+ # and cannot assign a stop-func to a breakpoint with a condition.
+
+ delete_breakpoints
+ set cond_bp [gdb_get_line_number "Break at multiply."]
+ gdb_scm_test_silent_cmd "guile (define eval-bp1 (make-bp-eval \"$cond_bp\"))" \
+ "create eval-bp1 breakpoint 2"
+ set test_cond {cond $bpnum}
+ gdb_test "$test_cond \"foo==3\"" \
+ "Only one stop condition allowed.*"
+ gdb_scm_test_silent_cmd "guile (define eval-bp2 (make-bp-basic \"$cond_bp\"))" \
+ "create basic breakpoint"
+ gdb_scm_test_silent_cmd "guile (set-breakpoint-condition! eval-bp2 \"1==1\")" \
+ "set a condition"
+ gdb_test_multiline "construct an eval function" \
+ "guile" "" \
+ "(define (stop-func bkpt)" "" \
+ " return #t)" "" \
+ "end" ""
+ gdb_test "guile (set-breakpoint-stop! eval-bp2 stop-func)" \
+ "Only one stop condition allowed.*"
+
+ # Check that stop-func is run when location has normal bp.
+
+ delete_breakpoints
+ gdb_breakpoint [gdb_get_line_number "Break at multiply."]
+ gdb_scm_test_silent_cmd "guile (define check-eval (make-bp-eval \"$bp_location2\"))" \
+ "create check-eval breakpoint"
+ gdb_test "guile (print (bp-eval-count check-eval))" \
+ "= 0" \
+ "test that evaluate function has not been yet executed (ie count = 0)"
+ gdb_continue_to_breakpoint "Break at multiply." ".*/$srcfile:$bp_location2.*"
+ gdb_test "guile (print (bp-eval-count check-eval))" \
+ "= 1" \
+ "test that evaluate function is run when location also has normal bp"
+
+ # Test watchpoints with stop-func.
+
+ gdb_test_multiline "watchpoint stop func" \
+ "guile" "" \
+ "(define (make-wp-eval location)" "" \
+ " (let ((wp (create-breakpoint! location #:type BP_WATCHPOINT #:wp-class WP_WRITE)))" "" \
+ " (set-breakpoint-stop! wp" "" \
+ " (lambda (bkpt)" "" \
+ " (let ((result (parse-and-eval \"result\")))" "" \
+ " (value=? result 788))))" "" \
+ " wp))" "" \
+ "end" ""
+
+ delete_breakpoints
+ gdb_scm_test_silent_cmd "guile (define wp1 (make-wp-eval \"result\"))" \
+ "create watchpoint"
+ gdb_test "continue" ".*\[Ww\]atchpoint.*result.*Old value =.*New value = 788.*" \
+ "test watchpoint write"
+
+ # Misc final tests.
+
+ gdb_test "guile (print (bp-eval-count never-eval-bp1))" \
+ "= 0" \
+ "check that this unrelated breakpoints eval function was never called"
+ }
+}
+
+test_bkpt_basic
+test_bkpt_deletion
+test_bkpt_cond_and_cmds
+test_bkpt_invisible
+test_watchpoints
+test_bkpt_internal
+test_bkpt_eval_funcs
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2014 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/>. */
+
+int
+main (void)
+{
+ return 0;
+}
--- /dev/null
+# Copyright 2014 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/>.
+
+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] {
+ return
+}
+
+# Disassemble one instruction at pc and verify the result.
+
+proc test_disassemble_1 { name address extra_args } {
+ with_test_prefix $name {
+ gdb_scm_test_silent_cmd "guile (define insn-list (arch-disassemble arch $address $extra_args #:size 1 #:count 1))" \
+ "disassemble"
+
+ gdb_test "guile (print (length insn-list))" \
+ "= 1" "test number of instructions"
+ gdb_scm_test_silent_cmd "guile (define insn (car insn-list))" \
+ "get instruction"
+
+ # Verify all the fields are present.
+ gdb_test "guile (print (->bool (assq-ref insn 'address)))" \
+ "= #t" "test key address"
+ gdb_test "guile (print (->bool (assq-ref insn 'asm)))" \
+ "= #t" "test key asm"
+ gdb_test "guile (print (->bool (assq-ref insn 'length)))" \
+ "= #t" "test key length"
+
+ # Verify the correct address is used.
+ gdb_test "guile (print (= $address (assq-ref insn 'address)))" \
+ "= #t" "verify correct address"
+ }
+}
+
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" "get frame"
+gdb_scm_test_silent_cmd "guile (define arch (frame-arch frame))" "get arch"
+gdb_scm_test_silent_cmd "guile (define pc (frame-pc frame))" "get pc"
+
+gdb_test "guile (print (arch-disassemble arch pc #:size 0))" \
+ "= \\(\\)" "disassemble, zero size"
+gdb_test "guile (print (arch-disassemble arch pc #:count 0))" \
+ "= \\(\\)" "disassemble, zero count"
+
+gdb_scm_test_silent_cmd "guile (define insn-list1 (arch-disassemble arch pc #:size 1 #:count 1))" \
+ "disassemble"
+gdb_scm_test_silent_cmd "guile (define insn-list2 (arch-disassemble arch pc #:size 1))" \
+ "disassemble, no count"
+gdb_scm_test_silent_cmd "guile (define insn-list3 (arch-disassemble arch pc #:count 1))" \
+ "disassemble, no end"
+gdb_scm_test_silent_cmd "guile (define insn-list4 (arch-disassemble arch pc))" \
+ "disassemble, no end no count"
+
+gdb_test "guile (print (length insn-list1))" \
+ "= 1" "test number of instructions 1"
+gdb_test "guile (print (length insn-list2))" \
+ "= 1" "test number of instructions 2"
+gdb_test "guile (print (length insn-list3))" \
+ "= 1" "test number of instructions 3"
+gdb_test "guile (print (length insn-list4))" \
+ "= 1" "test number of instructions 4"
+
+test_disassemble_1 "basic" "pc" ""
+
+# Negative test
+gdb_test "guile (arch-disassemble arch 0 #:size 1)" \
+ "ERROR: Cannot access memory at address 0x.*" "test bad memory access"
+
+# Test disassembly through a port.
+
+gdb_scm_test_silent_cmd "guile (define mem (open-memory))" \
+ "open memory port"
+
+test_disassemble_1 "memory-port" "pc" "#:port mem"
+
+gdb_scm_test_silent_cmd "guile (define insn-list-mem (arch-disassemble arch pc #:port mem #:size 1 #:count 1))" \
+ "disassemble via memory port"
+
+# Test memory error reading from port.
+
+gdb_scm_test_silent_cmd "guile (define mem1 (open-memory #:start pc #:size 4))" \
+ "open restricted range memory port"
+
+# The x86 disassembler tries to be clever and will print "byte 0x42" if
+# there is insufficient memory for the entire instruction.
+# So we pass "#:count 5" to ensure the disassembler tries to read beyond
+# the end of the memory range.
+gdb_test "guile (arch-disassemble arch pc #:port mem1 #:count 5 #:offset pc)" \
+ "ERROR: Cannot access memory at address 0x.*" \
+ "test bad memory access from port"
+
+# Test disassembly of a bytevector.
+
+gdb_scm_test_silent_cmd "guile (use-modules (rnrs io ports))" \
+ "import (rnrs io ports)"
+
+# First fetch the length of the instruction at $pc.
+gdb_scm_test_silent_cmd "guile (define insn-list-for-bv (arch-disassemble arch pc))" \
+ "get insn for bytevector"
+gdb_test_no_output "guile (define insn-length (assq-ref (car insn-list-for-bv) 'length))" \
+ "get insn length for bytevector"
+
+# Read the insn into a bytevector.
+gdb_test_no_output "guile (define insn-bv (get-bytevector-n (open-memory #:start pc #:size insn-length) insn-length))" \
+ "read insn into bytevector"
+
+# Disassemble the bytevector.
+gdb_scm_test_silent_cmd "guile (define insn-list-from-bv (arch-disassemble arch pc #:port (open-bytevector-input-port insn-bv) #:offset pc))" \
+ "disassemble bytevector"
+
+gdb_test "guile (print (equal? insn-list-for-bv insn-list-from-bv))" \
+ "= #t" "verify bytevector disassembly"
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2014 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/>. */
+
+int x;
+
+int
+main (void)
+{
+ return x;
+}
--- /dev/null
+# Copyright 2014 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 equal? for the various gsmobs.
+
+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] {
+ return
+}
+
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" "get frame"
+gdb_scm_test_silent_cmd "guile (define arch (frame-arch frame))" "get arch"
+
+gdb_test "guile (print (equal? (selected-frame) (newest-frame)))" \
+ "= #t" "equal? frame"
+gdb_test "guile (print (equal? (selected-frame) (frame-older (newest-frame))))" \
+ "= #f" "not equal? frame"
+
+gdb_test "guile (print (equal? (make-value 1) (make-value 1)))" \
+ "= #t" "equal? value"
+gdb_test "guile (print (equal? (make-value 1) (make-value 2)))" \
+ "= #f" "not equal? value"
+
+gdb_test "guile (print (equal? (value-type (make-value 1)) (value-type (make-value 2))))" \
+ "= #t" "equal? type"
+gdb_test "guile (print (equal? (value-type (make-value 1)) (value-type (make-value 2.5))))" \
+ "= #f" "not equal? type"
+
+gdb_test "guile (print (equal? (lookup-global-symbol \"main\") (lookup-global-symbol \"main\")))" \
+ "= #t" "equal? symbol"
+gdb_test "guile (print (equal? (lookup-global-symbol \"main\") (lookup-global-symbol \"x\")))" \
+ "= #f" "not equal? symbol"
--- /dev/null
+;; Copyright (C) 2014 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/>.
+
+(use-modules (gdb))
+
+;; An intentional error to test error handling when loading a file.
+(define foo (+ 42 #f))
--- /dev/null
+;; Copyright (C) 2014 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/>.
+
+(use-modules (gdb))
+
+;; Create a set of functions to call, with the last one having an error,
+;; so we can test backtrace printing.
+
+(define foo #f)
+
+(define (top-func x)
+ (+ (middle-func x) 1))
+
+(define (middle-func x)
+ (+ (bottom-func x) 1))
+
+(define (bottom-func x)
+ (+ x foo))
--- /dev/null
+# Copyright (C) 2010-2014 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/>.
+
+# Test various error conditions.
+
+set testfile "scm-error"
+
+load_lib gdb-guile.exp
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+# Test error while loading .scm.
+
+# Give the files a new name so we don't clobber the real one if
+# objfile == srcdir.
+set remote_guile_file_1 [gdb_remote_download host \
+ ${srcdir}/${subdir}/${testfile}-1.scm \
+ ${subdir}/t-${testfile}-1.scm]
+set remote_guile_file_2 [gdb_remote_download host \
+ ${srcdir}/${subdir}/${testfile}-2.scm \
+ ${subdir}/t-${testfile}-2.scm]
+
+gdb_test "source $remote_guile_file_1" \
+ "(ERROR: )?In procedure \[+\]: Wrong type: #f.*" \
+ "error loading scm file caught"
+
+gdb_test "p 1" " = 1" "no delayed error"
+
+# Test setting/showing the various states for "guile print-stack".
+
+gdb_test "show guile print-stack" \
+ "The mode of Guile exception printing on error is \"message\".*" \
+ "test print-stack show setting of default"
+gdb_test_no_output "set guile print-stack full" \
+ "test print-stack full setting"
+gdb_test "show guile print-stack" \
+ "The mode of Guile exception printing on error is \"full\".*" \
+ "test print-stack show setting to full"
+gdb_test_no_output "set guile print-stack none" \
+ "test print-stack none setting"
+gdb_test "show guile print-stack" \
+ "The mode of Guile exception printing on error is \"none\".*" \
+ "test print-stack show setting to none"
+# Reset back to default, just in case.
+gdb_test_no_output "set guile print-stack message" \
+ "reset print-stack to default, post set/show tests"
+
+# Test "set guile print-stack none".
+
+gdb_test_no_output "set guile print-stack none" \
+ "set print-stack to none, for error test"
+
+set test_name "no error printed"
+set command "guile (define x doesnt-exist)"
+gdb_test_multiple $command $test_name {
+ -re "Backtrace.*$gdb_prompt $" { fail $test_name }
+ -re "ERROR.*$gdb_prompt $" { fail $test_name }
+ -re "$gdb_prompt $" { pass $test_name }
+}
+
+# Test "set guile print-stack message".
+
+gdb_test_no_output "set guile print-stack message" \
+ "set print-stack to message, for error test"
+
+set test_name "error message printed"
+set command "guile (define x doesnt-exist)"
+gdb_test_multiple $command $test_name {
+ -re "Backtrace.*$gdb_prompt $" { fail $test_name }
+ -re "ERROR.*$gdb_prompt $" { pass $test_name }
+}
+
+# Test "set guile print-stack full".
+
+gdb_scm_test_silent_cmd "source $remote_guile_file_2" ""
+
+gdb_test_no_output "set guile print-stack full" \
+ "set print-stack to full, for backtrace test"
+
+gdb_test "guile (define x (top-func 42))" \
+ "Guile Backtrace:.*top-func 42.*middle-func 42.*bottom-func 42.*" \
+ "backtrace printed"
+
+# Verify gdb-specific errors are printed properly.
+# i.e., each gdb error is registered to use init.scm:%error-printer.
+
+gdb_test_no_output "set guile print-stack message" \
+ "set print-stack to message, for error printing tests"
+
+gdb_test "guile (throw 'gdb:error \"subr\" \"misc error: ~a\" (list 42))" \
+ "ERROR: In procedure subr: misc error: 42.*"
+
+gdb_test "guile (throw 'gdb:invalid-object-error \"subr\" \"invalid object error: ~a\" (list 42))" \
+ "ERROR: In procedure subr: invalid object error: 42.*"
+
+gdb_test "guile (throw 'gdb:memory-error \"subr\" \"memory error: ~a\" (list 42))" \
+ "ERROR: In procedure subr: memory error: 42.*"
+
+gdb_test "guile (throw 'gdb:pp-type-error \"subr\" \"pp-type error: ~a\" (list 42))" \
+ "ERROR: In procedure subr: pp-type error: 42.*"
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2014 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/>. */
+
+#include <string.h>
+
+struct s
+{
+ int m;
+};
+
+struct ss
+{
+ struct s a;
+ struct s b;
+};
+
+void
+init_s (struct s *s, int m)
+{
+ s->m = m;
+}
+
+void
+init_ss (struct ss *s, int a, int b)
+{
+ init_s (&s->a, a);
+ init_s (&s->b, b);
+}
+
+void
+foo (int x, struct ss ss)
+{
+ return; /* break-here */
+}
+
+int
+main ()
+{
+ struct ss ss;
+
+ init_ss (&ss, 1, 2);
+
+ foo (42, ss);
+
+ return 0;
+}
--- /dev/null
+# Copyright (C) 2014 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/>.
+
+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] {
+ return
+}
+
+# Give the file a new name so we don't clobber the real one if
+# objfile == srcdir.
+set remote_guile_file [gdb_remote_download host \
+ ${srcdir}/${subdir}/${testfile}.scm \
+ ${subdir}/t-${testfile}.scm]
+
+gdb_scm_load_file "$remote_guile_file" "load script"
+
+gdb_breakpoint [gdb_get_line_number "break-here"]
+gdb_continue_to_breakpoint "break-here" ".* break-here .*"
+
+# Test all combinations with raw off.
+
+gdb_test_no_output "set print raw frame-arguments off"
+
+gdb_test_no_output "set print frame-arguments none"
+gdb_test "frame" ".*foo \\(x=\[.\]{3}, ss=\[.\]{3}\\).*" \
+ "frame pretty,none"
+
+#gdb_test_no_output "set guile print-stack full"
+
+gdb_test_no_output "set print frame-arguments scalars"
+gdb_test "frame" ".*foo \\(x=42, ss=super struct = {\[.\]{3}}\\).*" \
+ "frame pretty,scalars"
+
+gdb_test_no_output "set print frame-arguments all"
+gdb_test "frame" \
+ ".*foo \\(x=42, ss=super struct = {a = m=<1>, b = m=<2>}\\).*" \
+ "frame pretty,all"
+
+# Test all combinations with raw on.
+
+gdb_test_no_output "set print raw frame-arguments on"
+
+gdb_test_no_output "set print frame-arguments none"
+gdb_test "frame" ".*foo \\(x=\[.\]{3}, ss=\[.\]{3}\\).*" \
+ "frame raw,none"
+
+gdb_test_no_output "set print frame-arguments scalars"
+gdb_test "frame" ".*foo \\(x=42, ss=\[.\]{3}\\).*" \
+ "frame raw,scalars"
+
+gdb_test_no_output "set print frame-arguments all"
+gdb_test "frame" \
+ ".*foo \\(x=42, ss={a = {m = 1}, b = {m = 2}}\\).*" \
+ "frame raw,all"
--- /dev/null
+;; Copyright (C) 2014 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/>.
+
+(use-modules (gdb) (gdb printing))
+
+(define (make-pp_s-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (let ((m (value-field val "m")))
+ (format #f "m=<~A>" m)))
+ #f))
+
+(define (make-pp_ss-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer) "super struct")
+ (lambda (printer)
+ (make-iterator val
+ (make-field-iterator (value-type val))
+ (lambda (iter)
+ (let ((field (iterator-next!
+ (iterator-progress iter))))
+ (if (end-of-iteration? field)
+ field
+ (let ((name (field-name field)))
+ (cons name (value-field val name))))))))))
+
+(define (get-type-for-printing val)
+ "Return type of val, stripping away typedefs, etc."
+ (let ((type (value-type val)))
+ (if (= (type-code type) TYPE_CODE_REF)
+ (set! type (type-target type)))
+ (type-strip-typedefs (type-unqualified type))))
+
+(define (make-pretty-printer-dict)
+ (let ((dict (make-hash-table)))
+ (hash-set! dict "struct s" make-pp_s-printer)
+ (hash-set! dict "s" make-pp_s-printer)
+ (hash-set! dict "struct ss" make-pp_ss-printer)
+ (hash-set! dict "ss" make-pp_ss-printer)
+ dict))
+
+(define *pretty-printer*
+ (make-pretty-printer
+ "pretty-printer-test"
+ (let ((pretty-printers-dict (make-pretty-printer-dict)))
+ (lambda (matcher val)
+ "Look-up and return a pretty-printer that can print val."
+ (let ((type (get-type-for-printing val)))
+ (let ((typename (type-tag type)))
+ (if typename
+ (let ((printer-maker (hash-ref pretty-printers-dict typename)))
+ (and printer-maker (printer-maker val)))
+ #f)))))))
+
+(append-pretty-printer! #f *pretty-printer*)
--- /dev/null
+/* This test is part of GDB, the GNU debugger.
+
+ Copyright 2011-2014 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/>. */
+
+volatile int v = 42;
+
+__attribute__((__always_inline__)) static inline int
+f (void)
+{
+ /* Provide first stub line so that GDB understand the PC is already inside
+ the inlined function and does not expect a step into it. */
+ v++;
+ v++; /* break-here */
+
+ return v;
+}
+
+__attribute__((__noinline__)) static int
+g (void)
+{
+ volatile int l = v;
+
+ return f ();
+}
+
+int
+main (void)
+{
+ return g ();
+}
--- /dev/null
+# Copyright (C) 2011-2014 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/>.
+
+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 ![runto main] {
+ fail "Can't run to main"
+ return
+}
+
+gdb_install_guile_utils
+gdb_install_guile_module
+
+gdb_breakpoint [gdb_get_line_number "break-here"]
+gdb_continue_to_breakpoint "break-here"
+
+gdb_test "info frame" "inlined into frame 1\r\n.*"
+
+gdb_test "up" "#1 g .*"
+
+gdb_test "guile (print (frame-read-var (selected-frame) \"l\"))" \
+ "= 42"
--- /dev/null
+int f2 (int a)
+{
+ return ++a;
+}
+
+int f1 (int a, int b)
+{
+ return f2(a) + b;
+}
+
+int block (void)
+{
+ int i = 99;
+ {
+ double i = 1.1;
+ double f = 2.2;
+ {
+ const char *i = "stuff";
+ const char *f = "foo";
+ const char *b = "bar";
+ return 0; /* Block break here. */
+ }
+ }
+}
+
+int main (int argc, char *argv[])
+{
+ block ();
+ return f1 (1, 2);
+}
--- /dev/null
+# Copyright (C) 2009-2014 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 frame support in Guile.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
+ return -1
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+# The following tests require execution.
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+gdb_breakpoint [gdb_get_line_number "Block break here."]
+gdb_continue_to_breakpoint "Block break here."
+gdb_scm_test_silent_cmd "guile (define bf1 (selected-frame))" \
+ "get frame"
+
+# Test frame-architecture method.
+gdb_scm_test_silent_cmd "guile (define show-arch-str (execute \"show architecture\" #:to-string #t))" \
+ "show arch"
+gdb_test "guile (print (->bool (string-contains show-arch-str (arch-name (frame-arch bf1)))))" \
+ "#t" "test frame-arch"
+
+# First test that read-var is unaffected by PR 11036 changes.
+gdb_test "guile (print (frame-read-var bf1 \"i\"))" \
+ "\"stuff\"" "test i"
+gdb_test "guile (print (frame-read-var bf1 \"f\"))" \
+ "\"foo\"" "test f"
+gdb_test "guile (print (frame-read-var bf1 \"b\"))" \
+ "\"bar\"" "test b"
+
+# Test the read-var function in another block other than the current
+# block (in this case, the super block). Test thar read-var is reading
+# the correct variables of i and f but they are the correct value and type.
+gdb_scm_test_silent_cmd "guile (define sb (block-superblock (frame-block bf1)))" \
+ "get superblock"
+gdb_test "guile (print (frame-read-var bf1 \"i\" #:block sb))" "1.1.*" \
+ "test i = 1.1"
+gdb_test "guile (print (value-type (frame-read-var bf1 \"i\" #:block sb)))" \
+ "double" "test double i"
+gdb_test "guile (print (frame-read-var bf1 \"f\" #:block sb))" \
+ "2.2.*" "test f = 2.2"
+gdb_test "guile (print (value-type (frame-read-var bf1 \"f\" #:block sb)))" \
+ "double" "test double f"
+
+# And again test another outerblock, this time testing "i" is the
+# correct value and type.
+gdb_scm_test_silent_cmd "guile (set! sb (block-superblock sb))" \
+ "get superblock #2"
+gdb_test "guile (print (frame-read-var bf1 \"i\" #:block sb))" \
+ "99" "test i = 99"
+gdb_test "guile (print (value-type (frame-read-var bf1 \"i\" #:block sb)))" \
+ "int" "test int i"
+
+gdb_breakpoint "f2"
+gdb_continue_to_breakpoint "breakpoint at f2"
+gdb_scm_test_silent_cmd "guile (define bframe (selected-frame))" \
+ "get bottom-most frame"
+gdb_test "up" ".*" ""
+
+gdb_scm_test_silent_cmd "guile (define f1 (selected-frame))" \
+"get second frame"
+gdb_scm_test_silent_cmd "guile (define f0 (frame-newer f1))" \
+ "get first frame"
+
+gdb_test "guile (print (eq? f1 (newest-frame)))" \
+ #f "selected frame -vs- newest frame"
+gdb_test "guile (print (eq? bframe (newest-frame)))" \
+ #t "newest frame -vs- newest frame"
+
+gdb_test "guile (print (eq? f0 f1))" \
+ "#f" "test equality comparison (false)"
+gdb_test "guile (print (eq? f0 f0))" \
+ "#t" "test equality comparison (true)"
+gdb_test "guile (print (frame-valid? f0))" \
+ "#t" "test frame-valid?"
+gdb_test "guile (print (frame-name f0))" \
+ "f2" "test frame-name"
+gdb_test "guile (print (= (frame-type f0) NORMAL_FRAME))" \
+ "#t" "test frame-type"
+gdb_test "guile (print (= (frame-unwind-stop-reason f0) FRAME_UNWIND_NO_REASON))" \
+ "#t" "test frame-unwind-stop-reason"
+gdb_test "guile (print (unwind-stop-reason-string FRAME_UNWIND_INNER_ID))" \
+ "previous frame inner to this frame \\(corrupt stack\\?\\)" \
+ "test unwind-stop-reason-string"
+gdb_test "guile (print (format #f \"= ~A\" (frame-pc f0)))" \
+ "= \[0-9\]+" "test frame-pc"
+gdb_test "guile (print (format #f \"= ~A\" (eq? (frame-older f0) f1)))" \
+ "= #t" "test frame-older"
+gdb_test "guile (print (format #f \"= ~A\" (eq? (frame-newer f1) f0)))" \
+ "= #t" "test frame-newer"
+gdb_test "guile (print (frame-read-var f0 \"variable_which_surely_doesnt_exist\"))" \
+ "ERROR: .*: Out of range: variable not found: \"variable_which_surely_doesnt_exist\".*" \
+ "test frame-read-var - error"
+gdb_test "guile (print (format #f \"= ~A\" (frame-read-var f0 \"a\")))" \
+ "= 1" "test frame-read-var - success"
+
+gdb_test "guile (print (format #f \"= ~A\" (eq? (selected-frame) f1)))" \
+ "= #t" "test selected-frame"
--- /dev/null
+# Copyright (C) 2010-2014 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 using GDB smobs with generics.
+
+load_lib gdb-guile.exp
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+gdb_reinitialize_dir $srcdir/$subdir
+
+gdb_install_guile_utils
+gdb_install_guile_module
+
+gdb_test_no_output "guile (use-modules ((oop goops)))"
+
+gdb_test_no_output "guile (define-generic +)"
+gdb_test_no_output "guile (define-method (+ (x <gdb:value>) (y <gdb:value>)) (value-add x y))"
+
+gdb_test_no_output "guile (define x (make-value 42))"
+
+gdb_test_no_output "guile (define y (+ x x))"
+
+gdb_test "guile y" "#<gdb:value 84>"
--- /dev/null
+# Copyright (C) 2014 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 gsmob features.
+
+load_lib gdb-guile.exp
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+gdb_reinitialize_dir $srcdir/$subdir
+
+gdb_install_guile_utils
+gdb_install_guile_module
+
+# Test the transition from alist to htab in the property list.
+# N.B. This has the same value as gdb/guile/scm-gsmob.c.
+set SMOB_PROP_HTAB_THRESHOLD 7
+
+gdb_test_no_output "gu (define arch (current-arch))"
+
+# Return a property name for integer I suitable for sorting.
+
+proc prop_name { i } {
+ return [format "prop%02d" $i]
+}
+
+# Set and ref the properties in separate loops to verify previously set
+# properties are not lost when we set a new property or switch to htabs.
+for {set i 0} {$i <= $SMOB_PROP_HTAB_THRESHOLD} {incr i} {
+ gdb_test "gu (print (gsmob-has-property? arch '[prop_name $i]))" \
+ "= #f" "property prop$i not present before set"
+ gdb_test_no_output "gu (set-gsmob-property! arch '[prop_name $i] $i)" \
+ "set prop $i"
+ gdb_test "gu (print (gsmob-has-property? arch '[prop_name $i]))" \
+ "= #t" "property prop$i present after set"
+}
+for {set i 0} {$i <= $SMOB_PROP_HTAB_THRESHOLD} {incr i} {
+ gdb_test "gu (print (gsmob-has-property? arch '[prop_name $i]))" \
+ "= #t" "property prop$i present after all set"
+ gdb_test "gu (print (gsmob-property arch '[prop_name $i]))" \
+ "= $i" "ref prop $i"
+}
+
+# Verify gsmob-properties.
+set prop_list ""
+for {set i 0} {$i <= $SMOB_PROP_HTAB_THRESHOLD} {incr i} {
+ set prop_list "$prop_list [prop_name $i]"
+}
+set prop_list [lsort $prop_list]
+verbose -log "prop_list: $prop_list"
+gdb_test "gu (print (sort (gsmob-properties arch) (lambda (a b) (string<? (symbol->string a) (symbol->string b)))))" \
+ "= \\($prop_list\\)" "gsmob-properties"
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2014 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/>. */
+
+void
+foo (void)
+{
+}
+
+int
+main (void)
+{
+ foo ();
+ return 0; /* Break at end. */
+}
--- /dev/null
+# Copyright (C) 2014 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 iterator facility.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
+ return -1
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+gdb_breakpoint [gdb_get_line_number "Break at end."]
+gdb_continue_to_breakpoint "Break at end."
+
+gdb_scm_test_silent_cmd "guile (use-modules (gdb iterator))" \
+ "import (gdb iterator)"
+
+gdb_scm_test_silent_cmd "guile (define this-sal (find-pc-line (frame-pc (selected-frame))))" \
+ "get frame sal"
+
+gdb_scm_test_silent_cmd "guile (define this-symtab (sal-symtab this-sal))" \
+ "get frame symtab"
+
+gdb_scm_test_silent_cmd "guile (define this-global-block (symtab-global-block this-symtab))" \
+ "get frame global block"
+
+gdb_scm_test_silent_cmd "guile (define syms-iter (make-block-symbols-iterator this-global-block))" \
+ "get global block iterator"
+
+gdb_scm_test_silent_cmd "guile (define functions (iterator-filter symbol-function? syms-iter))" \
+ "get global functions"
+
+gdb_test "guile (print (sort (map symbol-name functions) string<?))" \
+ "= \\(foo main\\)" "test function list"
+
+gdb_scm_test_silent_cmd "guile (define syms-iter (make-block-symbols-iterator this-global-block))" \
+ "get global block iterator 2"
+
+gdb_test "guile (print (sort (map symbol-name (iterator->list syms-iter)) string<?))" \
+ "= \\(foo main\\)" "iterator->list"
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2014 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/>. */
+
+enum e
+ {
+ ONE = 1,
+ TWO = 2
+ };
+
+enum e evalue = TWO;
+
+int
+main (int argc, char *argv[])
+{
+ return 0;
+}
--- /dev/null
+# Copyright (C) 2008-2014 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 <gdb:value> math operations.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+proc test_value_numeric_ops {} {
+ global gdb_prompt
+
+ gdb_scm_test_silent_cmd "gu (define i (make-value 5))" \
+ "create first integer value"
+ gdb_scm_test_silent_cmd "gu (define j (make-value 2))" \
+ "create second integer value"
+ gdb_test "gu (print (value-add i j))" \
+ "= 7" "add two integer values"
+ gdb_test "gu (raw-print (value-add i j))" \
+ "= #<gdb:value 7>" "verify type of integer add result"
+
+ gdb_scm_test_silent_cmd "gu (define f (make-value 1.25))" \
+ "create first double value"
+ gdb_scm_test_silent_cmd "gu (define g (make-value 2.5))" \
+ "create second double value"
+ gdb_test "gu (print (value-add f g))" \
+ "= 3.75" "add two double values"
+ gdb_test "gu (raw-print (value-add f g))" \
+ "= #<gdb:value 3.75>" "verify type of double add result"
+
+ gdb_test "gu (print (value-sub i j))" \
+ "= 3" "subtract two integer values"
+ gdb_test "gu (print (value-sub f g))" \
+ "= -1.25" "subtract two double values"
+
+ gdb_test "gu (print (value-mul i j))" \
+ "= 10" "multiply two integer values"
+ gdb_test "gu (print (value-mul f g))" \
+ "= 3.125" "multiply two double values"
+
+ gdb_test "gu (print (value-div i j))" \
+ "= 2" "divide two integer values"
+ gdb_test "gu (print (value-div f g))" \
+ "= 0.5" "divide two double values"
+ gdb_test "gu (print (value-rem i j))" \
+ "= 1" "take remainder of two integer values"
+ gdb_test "gu (print (value-mod i j))" \
+ "= 1" "take modulus of two integer values"
+
+ gdb_test "gu (print (value-pow i j))" \
+ "= 25" "integer value raised to the power of another integer value"
+ gdb_test "gu (print (value-pow g j))" \
+ "= 6.25" "double value raised to the power of integer value"
+
+ gdb_test "gu (print (value-neg i))" \
+ "= -5" "negated integer value"
+ gdb_test "gu (print (value-pos i))" \
+ "= 5" "positive integer value"
+ gdb_test "gu (print (value-neg f))" \
+ "= -1.25" "negated double value"
+ gdb_test "gu (print (value-pos f))" \
+ "= 1.25" "positive double value"
+ gdb_test "gu (print (value-abs (value-sub j i)))" \
+ "= 3" "absolute of integer value"
+ gdb_test "gu (print (value-abs (value-sub f g)))" \
+ "= 1.25" "absolute of double value"
+
+ gdb_test "gu (print (value-lsh i j))" \
+ "= 20" "left shift"
+ gdb_test "gu (print (value-rsh i j))" \
+ "= 1" "right shift"
+
+ gdb_test "gu (print (value-min i j))" \
+ "= 2" "min"
+ gdb_test "gu (print (value-max i j))" \
+ "= 5" "max"
+
+ gdb_test "gu (print (value-lognot i))" \
+ "= -6" "lognot"
+ gdb_test "gu (print (value-logand i j))" \
+ "= 0" "logand i j"
+ gdb_test "gu (print (value-logand 5 1))" \
+ "= 1" "logand 5 1"
+ gdb_test "gu (print (value-logior i j))" \
+ "= 7" "logior i j"
+ gdb_test "gu (print (value-logior 5 1))" \
+ "= 5" "logior 5 1"
+ gdb_test "gu (print (value-logxor i j))" \
+ "= 7" "logxor i j"
+ gdb_test "gu (print (value-logxor 5 1))" \
+ "= 4" "logxor 5 1"
+
+ # Test <gdb:value> mixed with Guile types.
+
+ gdb_test "gu (print (value-sub i 1))" \
+ "= 4" "subtract integer value from guile integer"
+ gdb_test "gu (raw-print (value-sub i 1))" \
+ "#<gdb:value 4>" \
+ "verify type of mixed integer subtraction result"
+ gdb_test "gu (print (value-add f 1.5))" \
+ "= 2.75" "add double value with guile float"
+
+ gdb_test "gu (print (value-sub 1 i))" \
+ "= -4" "subtract guile integer from integer value"
+ gdb_test "gu (print (value-add 1.5 f))" \
+ "= 2.75" "add guile float with double value"
+
+ # Enum conversion test.
+ gdb_test "print evalue" "= TWO"
+ gdb_test "gu (print (value->integer (history-ref 0)))" "= 2"
+
+ # Test pointer arithmetic.
+
+ # First, obtain the pointers.
+ gdb_test "print (void *) 2" ".*" ""
+ gdb_test_no_output "gu (define a (history-ref 0))"
+ gdb_test "print (void *) 5" ".*" ""
+ gdb_test_no_output "gu (define b (history-ref 0))"
+
+ gdb_test "gu (print (value-add a 5))" \
+ "= 0x7( <.*>)?" "add pointer value with guile integer"
+ gdb_test "gu (print (value-sub b 2))" \
+ "= 0x3( <.*>)?" "subtract guile integer from pointer value"
+ gdb_test "gu (print (value-sub b a))" \
+ "= 3" "subtract two pointer values"
+
+ # Test some invalid operations.
+
+ gdb_test_multiple "gu (print (value-add i '()))" "catch error in guile type conversion" {
+ -re "Wrong type argument in position 2.*$gdb_prompt $" {pass "catch error in guile type conversion"}
+ -re "= .*$gdb_prompt $" {fail "catch error in guile type conversion"}
+ -re "$gdb_prompt $" {fail "catch error in guile type conversion"}
+ }
+
+ gdb_test_multiple "gu (print (value-add i \"foo\"))" "catch throw of GDB error" {
+ -re "Argument to arithmetic operation not a number or boolean.*$gdb_prompt $" {pass "catch throw of GDB error"}
+ -re "= .*$gdb_prompt $" {fail "catch throw of GDB error"}
+ -re "$gdb_prompt $" {fail "catch throw of GDB error"}
+ }
+}
+
+# Return the max signed int of size SIZE.
+# TCL 8.5 required here. Use lookup table instead?
+
+proc get_max_int { size } {
+ return [expr "(1 << ($size - 1)) - 1"]
+}
+
+# Return the min signed int of size SIZE.
+# TCL 8.5 required here. Use lookup table instead?
+
+proc get_min_int { size } {
+ return [expr "-(1 << ($size - 1))"]
+}
+
+# Return the max unsigned int of size SIZE.
+# TCL 8.5 required here. Use lookup table instead?
+
+proc get_max_uint { size } {
+ return [expr "(1 << $size) - 1"]
+}
+
+# Helper routine for test_value_numeric_ranges.
+
+proc test_make_int_value { name size } {
+ set max [get_max_int $size]
+ set min [get_min_int $size]
+ set umax [get_max_uint $size]
+ gdb_test "gu (print (value-type (make-value $max)))" \
+ "= $name" "test make-value $name $size max"
+ gdb_test "gu (print (value-type (make-value $min)))" \
+ "= $name" "test make-value $name $size min"
+ gdb_test "gu (print (value-type (make-value $umax)))" \
+ "= unsigned $name" "test make-value unsigned $name $size umax"
+}
+
+# Helper routine for test_value_numeric_ranges.
+
+proc test_make_typed_int_value { size } {
+ set name "int$size"
+ set uname "uint$size"
+ set max [get_max_int $size]
+ set min [get_min_int $size]
+ set umax [get_max_uint $size]
+
+ gdb_test "gu (print (make-value $max #:type (arch-${name}-type arch)))" \
+ "= $max" "test make-value $name $size max"
+ gdb_test "gu (print (make-value $min #:type (arch-${name}-type arch)))" \
+ "= $min" "test make-value $name $size min"
+ gdb_test "gu (print (make-value $umax #:type (arch-${uname}-type arch)))" \
+ "= $umax" "test make-value $uname $size umax"
+
+ gdb_test "gu (print (make-value (+ $max 1) #:type (arch-${name}-type arch)))" \
+ "ERROR.*Out of range.*" "test make-value $name $size max+1"
+ gdb_test "gu (print (make-value (- $min 1) #:type (arch-${name}-type arch)))" \
+ "ERROR.*Out of range.*" "test make-value $name $size min-1"
+ gdb_test "gu (print (make-value (+ $umax 1) #:type (arch-${uname}-type arch)))" \
+ "ERROR.*Out of range.*" "test make-value $uname $size umax+1"
+}
+
+proc test_value_numeric_ranges {} {
+ # We can't assume anything about sizeof (int), etc. on the target.
+ # Keep it simple for now, this will cover everything important for
+ # the major targets.
+ set int_size [get_sizeof "int" 0]
+ set long_size [get_sizeof "long" 0]
+ gdb_test_no_output "gu (define arch (current-arch))"
+
+ if { $int_size == 4 } {
+ test_make_int_value int 32
+ }
+ if { $long_size == 8} {
+ test_make_int_value long 64
+ }
+ gdb_test "gu (print (value-type (make-value (ash 1 64))))" \
+ "ERROR:.*value not a number representable.*" \
+ "test make-value, number too large"
+
+ foreach size { 8 16 32 } {
+ test_make_typed_int_value $size
+ }
+ if { $long_size == 8 } {
+ test_make_typed_int_value 64
+ }
+}
+
+proc test_value_boolean {} {
+ # Note: Boolean values print as 0,1 because they are printed in the
+ # current language (in this case C).
+
+ gdb_test "gu (print (make-value #t))" "= 1" "create boolean true"
+ gdb_test "gu (print (make-value #f))" "= 0" "create boolean false"
+
+ gdb_test "gu (print (value-not (make-value #t)))" \
+ "= 0" "not true"
+ gdb_test "gu (print (value-not (make-value #f)))" \
+ "= 1" "not false"
+
+ gdb_test "gu (raw-print (make-value #t))" \
+ "#<gdb:value 1>" "verify type of boolean"
+}
+
+proc test_value_compare {} {
+ gdb_test "gu (print (value<? 1 1))" \
+ "#f" "less than, equal"
+ gdb_test "gu (print (value<? 1 2))" \
+ "#t" "less than, less"
+ gdb_test "gu (print (value<? 2 1))" \
+ "#f" "less than, greater"
+
+ gdb_test "gu (print (value<=? 1 1))" \
+ "#t" "less or equal, equal"
+ gdb_test "gu (print (value<=? 1 2))" \
+ "#t" "less or equal, less"
+ gdb_test "gu (print (value<=? 2 1))" \
+ "#f" "less or equal, greater"
+
+ gdb_test "gu (print (value=? 1 1))" \
+ "#t" "equality"
+ gdb_test "gu (print (value=? 1 2))" \
+ "#f" "inequality"
+ gdb_test "gu (print (value=? (make-value 1) 1.0))" \
+ "#t" "equality of gdb:value with Guile value"
+ gdb_test "gu (print (value=? (make-value 1) 2))" \
+ "#f" "inequality of gdb:value with Guile value"
+
+ gdb_test "gu (print (value>? 1 1))" \
+ "#f" "greater than, equal"
+ gdb_test "gu (print (value>? 1 2))" \
+ "#f" "greater than, less"
+ gdb_test "gu (print (value>? 2 1))" \
+ "#t" "greater than, greater"
+
+ gdb_test "gu (print (value>=? 1 1))" \
+ "#t" "greater or equal, equal"
+ gdb_test "gu (print (value>=? 1 2))" \
+ "#f" "greater or equal, less"
+ gdb_test "gu (print (value>=? 2 1))" \
+ "#t" "greater or equal, greater"
+}
+
+if {[prepare_for_testing $testfile.exp $testfile $srcfile {debug c}]} {
+ return
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+test_value_numeric_ops
+test_value_numeric_ranges
+test_value_boolean
+test_value_compare
--- /dev/null
+;; Copyright (C) 2011-2014 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.
+
+(use-modules (gdb) (gdb printing))
+
+(define (make-pp_ss-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (let ((a (value-field val "a"))
+ (b (value-field val "b")))
+ (format #f "a=<~A> b=<~A>" a b)))
+ #f))
+
+(define (get-type-for-printing val)
+ "Return type of val, stripping away typedefs, etc."
+ (let ((type (value-type val)))
+ (if (= (type-code type) TYPE_CODE_REF)
+ (set! type (type-target type)))
+ (type-strip-typedefs (type-unqualified type))))
+
+(define (make-pretty-printer-dict)
+ (let ((dict (make-hash-table)))
+ (hash-set! dict "struct ss" make-pp_ss-printer)
+ (hash-set! dict "ss" make-pp_ss-printer)
+ dict))
+
+(define *pretty-printer*
+ (make-pretty-printer
+ "pretty-printer-test"
+ (let ((pretty-printers-dict (make-pretty-printer-dict)))
+ (lambda (matcher val)
+ "Look-up and return a pretty-printer that can print val."
+ (let ((type (get-type-for-printing val)))
+ (let ((typename (type-tag type)))
+ (if typename
+ (let ((printer-maker (hash-ref pretty-printers-dict typename)))
+ (and printer-maker (printer-maker val)))
+ #f)))))))
+
+(append-pretty-printer! #f *pretty-printer*)
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2011-2014 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 ss
+{
+ int a;
+ int b;
+};
+
+void
+init_ss (struct ss *s, int a, int b)
+{
+ s->a = a;
+ s->b = b;
+}
+
+int
+main ()
+{
+ struct ss ss;
+
+ init_ss (&ss, 1, 2);
+
+ return 0; /* break to inspect struct and union */
+}
--- /dev/null
+# Copyright (C) 2011-2014 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 automagic loading of -gdb.scm scripts.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+if {[build_executable $testfile.exp $testfile $srcfile debug] == -1} {
+ return
+}
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+# Make the -gdb.scm script available to gdb, it is automagically loaded by gdb.
+# Care is taken to put it in the same directory as the binary so that
+# gdb will find it.
+set remote_guile_file [remote_download host \
+ ${srcdir}/${subdir}/${testfile}-gdb.in \
+ [standard_output_file ${testfile}-gdb.scm]]
+
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_test_no_output "set auto-load safe-path ${remote_guile_file}" \
+ "set auto-load safe-path"
+gdb_load ${binfile}
+
+# Verify gdb loaded the script.
+gdb_test "info auto-load guile-scripts" "Yes.*/${testfile}-gdb.scm.*"
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+gdb_test "b [gdb_get_line_number {break to inspect} ${testfile}.c ]" \
+ ".*Breakpoint.*"
+gdb_test "continue" ".*Breakpoint.*"
+
+gdb_test "print ss" " = a=<1> b=<2>"
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2011-2014 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/>. */
+
+int
+main ()
+{
+ int some_var = 0;
+ return 0;
+}
--- /dev/null
+# Copyright (C) 2011-2014 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 objfile support in Guile.
+
+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
+}
+
+gdb_scm_test_silent_cmd "gu (define sym (lookup-symbol \"some_var\"))" \
+ "Find a symbol in objfile"
+gdb_scm_test_silent_cmd "gu (define objfile (symtab-objfile (symbol-symtab (car sym))))" \
+ "Get backing object file"
+
+gdb_test "gu (print (objfile-filename objfile))" \
+ ".*scm-objfile.*" "Get objfile filename"
+gdb_test "gu (print (objfile-valid? objfile))" \
+ "#t" "Get objfile validity"
+
+gdb_test "gu (print (->bool (or-map (lambda (o) (string-contains (objfile-filename o) \"scm-objfile\")) (objfiles))))" \
+ "= #t" "scm-objfile in objfile list"
+
+gdb_test "gu (print (objfile-pretty-printers objfile))" \
+ "= \\(\\)"
+
+gdb_test "guile (set-objfile-pretty-printers! objfile 0)" \
+ "ERROR: .*: Wrong type argument in position 2 \\(expecting list\\): 0.*"
+
+# Do this last.
+gdb_unload
+gdb_test "gu (print (objfile-valid? objfile))" \
+ "#f" "Get objfile validity after unload"
--- /dev/null
+# Copyright (C) 2014 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 GDB provided ports.
+
+load_lib gdb-guile.exp
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+gdb_reinitialize_dir $srcdir/$subdir
+
+gdb_install_guile_utils
+gdb_install_guile_module
+
+gdb_test "guile (print (stdio-port? 42))" "= #f"
+gdb_test "guile (print (stdio-port? (%make-void-port \"r\")))" "= #f"
+gdb_test "guile (print (stdio-port? (input-port)))" "= #t"
+gdb_test "guile (print (stdio-port? (output-port)))" "= #t"
+gdb_test "guile (print (stdio-port? (error-port)))" "= #t"
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2008-2014 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/>. */
+
+#include <string.h>
+
+struct s
+{
+ int a;
+ int *b;
+};
+
+struct ss
+{
+ struct s a;
+ struct s b;
+};
+
+struct arraystruct
+{
+ int y;
+ struct s x[2];
+};
+
+struct ns {
+ const char *null_str;
+ int length;
+};
+
+struct lazystring {
+ const char *lazy_str;
+};
+
+struct hint_error {
+ int x;
+};
+
+struct children_as_list {
+ int x;
+};
+
+#ifdef __cplusplus
+struct S : public s {
+ int zs;
+};
+
+struct SS {
+ int zss;
+ S s;
+};
+
+struct SSS
+{
+ SSS (int x, const S& r);
+ int a;
+ const S &b;
+};
+SSS::SSS (int x, const S& r) : a(x), b(r) { }
+
+class VirtualTest
+{
+ private:
+ int value;
+
+ public:
+ VirtualTest ()
+ {
+ value = 1;
+ }
+};
+
+class Vbase1 : public virtual VirtualTest { };
+class Vbase2 : public virtual VirtualTest { };
+class Vbase3 : public virtual VirtualTest { };
+
+class Derived : public Vbase1, public Vbase2, public Vbase3
+{
+ private:
+ int value;
+
+ public:
+ Derived ()
+ {
+ value = 2;
+ }
+};
+
+class Fake
+{
+ int sname;
+
+ public:
+ Fake (const int name = 0):
+ sname (name)
+ {
+ }
+};
+#endif
+
+struct substruct {
+ int a;
+ int b;
+};
+
+struct outerstruct {
+ struct substruct s;
+ int x;
+};
+
+struct outerstruct
+substruct_test (void)
+{
+ struct outerstruct outer;
+ outer.s.a = 0;
+ outer.s.b = 0;
+ outer.x = 0;
+
+ outer.s.a = 3; /* MI outer breakpoint here */
+
+ return outer;
+}
+
+typedef struct string_repr
+{
+ struct whybother
+ {
+ const char *contents;
+ } whybother;
+} string;
+
+/* This lets us avoid malloc. */
+int array[100];
+int narray[10];
+
+struct justchildren
+{
+ int len;
+ int *elements;
+};
+
+typedef struct justchildren nostring_type;
+
+struct memory_error
+{
+ const char *s;
+};
+
+struct container
+{
+ string name;
+ int len;
+ int *elements;
+};
+
+typedef struct container zzz_type;
+
+string
+make_string (const char *s)
+{
+ string result;
+ result.whybother.contents = s;
+ return result;
+}
+
+zzz_type
+make_container (const char *s)
+{
+ zzz_type result;
+
+ result.name = make_string (s);
+ result.len = 0;
+ result.elements = 0;
+
+ return result;
+}
+
+void
+add_item (zzz_type *c, int val)
+{
+ if (c->len == 0)
+ c->elements = array;
+ c->elements[c->len] = val;
+ ++c->len;
+}
+
+void
+set_item(zzz_type *c, int i, int val)
+{
+ if (i < c->len)
+ c->elements[i] = val;
+}
+
+void init_s(struct s *s, int a)
+{
+ s->a = a;
+ s->b = &s->a;
+}
+
+void init_ss(struct ss *s, int a, int b)
+{
+ init_s(&s->a, a);
+ init_s(&s->b, b);
+}
+
+void do_nothing(void)
+{
+ int c;
+
+ c = 23; /* Another MI breakpoint */
+}
+
+struct nullstr
+{
+ char *s;
+};
+
+struct string_repr string_1 = { { "one" } };
+struct string_repr string_2 = { { "two" } };
+
+static int
+eval_func (int p1, int p2, int p3, int p4, int p5, int p6, int p7, int p8)
+{
+ return p1;
+}
+
+static void
+eval_sub (void)
+{
+ struct eval_type_s { int x; } eval1 = { 1 }, eval2 = { 2 }, eval3 = { 3 },
+ eval4 = { 4 }, eval5 = { 5 }, eval6 = { 6 },
+ eval7 = { 7 }, eval8 = { 8 }, eval9 = { 9 };
+
+ eval1.x++; /* eval-break */
+}
+
+static void
+bug_14741()
+{
+ zzz_type c = make_container ("bug_14741");
+ add_item (&c, 71);
+ set_item(&c, 0, 42); /* breakpoint bug 14741 */
+ set_item(&c, 0, 5);
+}
+
+int
+main ()
+{
+ struct ss ss;
+ struct ss ssa[2];
+ struct arraystruct arraystruct;
+ string x = make_string ("this is x");
+ zzz_type c = make_container ("container");
+ zzz_type c2 = make_container ("container2");
+ const struct string_repr cstring = { { "const string" } };
+ /* Clearing by being `static' could invoke an other GDB C++ bug. */
+ struct nullstr nullstr;
+ nostring_type nstype, nstype2;
+ struct memory_error me;
+ struct ns ns, ns2;
+ struct lazystring estring, estring2;
+ struct hint_error hint_error;
+ struct children_as_list children_as_list;
+
+ nstype.elements = narray;
+ nstype.len = 0;
+
+ me.s = "blah";
+
+ init_ss(&ss, 1, 2);
+ init_ss(ssa+0, 3, 4);
+ init_ss(ssa+1, 5, 6);
+ memset (&nullstr, 0, sizeof nullstr);
+
+ arraystruct.y = 7;
+ init_s (&arraystruct.x[0], 23);
+ init_s (&arraystruct.x[1], 24);
+
+ ns.null_str = "embedded\0null\0string";
+ ns.length = 20;
+
+ /* Make a "corrupted" string. */
+ ns2.null_str = NULL;
+ ns2.length = 20;
+
+ estring.lazy_str = "embedded x\201\202\203\204" ;
+
+ /* Incomplete UTF-8, but ok Latin-1. */
+ estring2.lazy_str = "embedded x\302";
+
+#ifdef __cplusplus
+ S cps;
+
+ cps.zs = 7;
+ init_s(&cps, 8);
+
+ SS cpss;
+ cpss.zss = 9;
+ init_s(&cpss.s, 10);
+
+ SS cpssa[2];
+ cpssa[0].zss = 11;
+ init_s(&cpssa[0].s, 12);
+ cpssa[1].zss = 13;
+ init_s(&cpssa[1].s, 14);
+
+ SSS sss(15, cps);
+
+ SSS& ref (sss);
+
+ Derived derived;
+
+ Fake fake (42);
+#endif
+
+ add_item (&c, 23); /* MI breakpoint here */
+ add_item (&c, 72);
+
+#ifdef MI
+ add_item (&c, 1011);
+ c.elements[0] = 1023;
+ c.elements[0] = 2323;
+
+ add_item (&c2, 2222);
+ add_item (&c2, 3333);
+
+ substruct_test ();
+ do_nothing ();
+#endif
+
+ nstype.elements[0] = 7;
+ nstype.elements[1] = 42;
+ nstype.len = 2;
+
+ nstype2 = nstype;
+
+ eval_sub ();
+
+ bug_14741(); /* break to inspect struct and union */
+ return 0;
+}
--- /dev/null
+# Copyright (C) 2008-2014 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 Guile-based pretty-printing for the CLI.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+proc run_lang_tests {exefile lang} {
+ global srcdir subdir srcfile testfile hex
+ if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${exefile}" executable "debug $lang"] != "" } {
+ untested "Couldn't compile ${srcfile} in $lang mode"
+ return
+ }
+
+ set nl "\[\r\n\]+"
+
+ # Start with a fresh gdb.
+ gdb_exit
+ gdb_start
+ gdb_reinitialize_dir $srcdir/$subdir
+ gdb_load ${exefile}
+
+ if ![gdb_guile_runto_main] {
+ return
+ }
+
+ gdb_test_no_output "set print pretty on"
+
+ gdb_test "b [gdb_get_line_number {break to inspect} ${testfile}.c ]" \
+ ".*Breakpoint.*"
+ gdb_test "continue" ".*Breakpoint.*"
+
+ set remote_scheme_file [gdb_remote_download host \
+ ${srcdir}/${subdir}/${testfile}.scm]
+
+ gdb_scm_load_file ${remote_scheme_file}
+
+ gdb_test "print ss" " = a=<a=<1> b=<$hex>> b=<a=<2> b=<$hex>>"
+ gdb_test "print ssa\[1\]" " = a=<a=<5> b=<$hex>> b=<a=<6> b=<$hex>>"
+ gdb_test "print ssa" " = {a=<a=<3> b=<$hex>> b=<a=<4> b=<$hex>>, a=<a=<5> b=<$hex>> b=<a=<6> b=<$hex>>}"
+
+ gdb_test "print arraystruct" " = {$nl *y = 7, *$nl *x = {a=<23> b=<$hex>, a=<24> b=<$hex>} *$nl *}"
+
+ if {$lang == "c++"} {
+ gdb_test "print cps" "= a=<8> b=<$hex>"
+ gdb_test "print cpss" " = {$nl *zss = 9, *$nl *s = a=<10> b=<$hex>$nl}"
+ gdb_test "print cpssa\[0\]" " = {$nl *zss = 11, *$nl *s = a=<12> b=<$hex>$nl}"
+ gdb_test "print cpssa\[1\]" " = {$nl *zss = 13, *$nl *s = a=<14> b=<$hex>$nl}"
+ gdb_test "print cpssa" " = {{$nl *zss = 11, *$nl *s = a=<12> b=<$hex>$nl *}, {$nl *zss = 13, *$nl *s = a=<14> b=<$hex>$nl *}}"
+ gdb_test "print sss" "= a=<15> b=<a=<8> b=<$hex>>"
+ gdb_test "print ref" "= a=<15> b=<a=<8> b=<$hex>>"
+ gdb_test "print derived" \
+ " = \{.*<Vbase1> = pp class name: Vbase1.*<Vbase2> = \{.*<VirtualTest> = pp value variable is: 1,.*members of Vbase2:.*_vptr.Vbase2 = $hex.*<Vbase3> = \{.*members of Vbase3.*members of Derived:.*value = 2.*"
+ gdb_test "print ns " "\"embedded\\\\000null\\\\000string\""
+ gdb_scm_test_silent_cmd "set print elements 3" "" 1
+ gdb_test "print ns" "emb\.\.\.."
+ gdb_scm_test_silent_cmd "set print elements 10" "" 1
+ gdb_test "print ns" "embedded\\\\000n\.\.\.."
+ gdb_scm_test_silent_cmd "set print elements 200" "" 1
+ }
+
+ gdb_test "print ns2" "<error reading variable: ERROR: Cannot access memory at address 0x0>"
+
+ gdb_test "print x" " = \"this is x\""
+ gdb_test "print cstring" " = \"const string\""
+
+ gdb_test "print estring" " = \"embedded x\\\\201\\\\202\\\\203\\\\204\""
+
+ gdb_test_no_output "guile (set! *pp-ls-encoding* \"UTF-8\")"
+ gdb_test "print estring2" "\"embedded \", <incomplete sequence \\\\302>"
+
+ gdb_test_no_output "set guile print-stack full"
+ gdb_test "print hint_error" "ERROR: Invalid display hint: 42\r\nhint_error_val"
+
+ gdb_test "print c" " = container \"container\" with 2 elements = {$nl *.0. = 23,$nl *.1. = 72$nl}"
+
+ gdb_test "print nstype" " = {$nl *.0. = 7,$nl *.1. = 42$nl}"
+
+ gdb_test_no_output "set print pretty off"
+ gdb_test "print nstype" " = {.0. = 7, .1. = 42}" \
+ "print nstype on one line"
+
+ gdb_continue_to_end
+}
+
+run_lang_tests "${binfile}" "c"
+run_lang_tests "${binfile}-cxx" "c++"
+
+# Run various other tests.
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_load ${binfile}
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+set remote_scheme_file [gdb_remote_download host \
+ ${srcdir}/${subdir}/${testfile}.scm]
+
+gdb_scm_load_file ${remote_scheme_file}
+
+gdb_breakpoint [gdb_get_line_number "eval-break"]
+gdb_continue_to_breakpoint "eval-break" ".* eval-break .*"
+
+gdb_test "info locals" "eval9 = eval=<123456789>"
+
+gdb_test "b [gdb_get_line_number {break to inspect} ${testfile}.c ]" \
+ ".*Breakpoint.*"
+gdb_test "continue" ".*Breakpoint.*"
+
+gdb_test "print ss" " = a=<a=<1> b=<$hex>> b=<a=<2> b=<$hex>>" \
+ "print ss enabled #1"
+
+gdb_test_no_output "guile (disable-matcher!)"
+
+gdb_test "print ss" " = {a = {a = 1, b = $hex}, b = {a = 2, b = $hex}}" \
+ "print ss disabled"
+
+gdb_test_no_output "guile (enable-matcher!)"
+
+gdb_test "print ss" " = a=<a=<1> b=<$hex>> b=<a=<2> b=<$hex>>" \
+ "print ss enabled #2"
--- /dev/null
+;; Copyright (C) 2008-2014 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 Scheme pretty printers.
+
+(use-modules (gdb) (gdb printing))
+
+(define (make-pointer-iterator pointer len)
+ (let ((next! (lambda (iter)
+ (let* ((start (iterator-object iter))
+ (progress (iterator-progress iter))
+ (current (car progress))
+ (len (cdr progress)))
+ (if (= current len)
+ (end-of-iteration)
+ (let ((pointer (value-add start current)))
+ (set-car! progress (+ current 1))
+ (cons (format #f "[~A]" current)
+ (value-dereference pointer))))))))
+ (make-iterator pointer (cons 0 len) next!)))
+
+(define (make-pointer-iterator-except pointer len)
+ (let ((next! (lambda (iter)
+ (if *exception-flag*
+ (throw 'gdb:memory-error "hi bob"))
+ (let* ((start (iterator-object iter))
+ (progress (iterator-progress iter))
+ (current (car progress))
+ (len (cdr progress)))
+ (if (= current len)
+ (end-of-iteration)
+ (let ((pointer (value-add start current)))
+ (set-car! progress (+ current 1))
+ (cons (format #f "[~A]" current)
+ (value-dereference pointer))))))))
+ (make-iterator pointer (cons 0 len) next!)))
+
+;; Test returning a <gdb:value> from a printer.
+
+(define (make-string-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (value-field (value-field val "whybother")
+ "contents"))
+ #f))
+
+;; Test a printer with children.
+
+(define (make-container-printer val)
+ ;; This is a little different than the Python version in that if there's
+ ;; an error accessing these fields we'll throw it at matcher time instead
+ ;; of at printer time. Done this way to explore the possibilities.
+ (let ((name (value-field val "name"))
+ (len (value-field val "len"))
+ (elements (value-field val "elements")))
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (format #f "container ~A with ~A elements"
+ name len))
+ (lambda (printer)
+ (make-pointer-iterator elements (value->integer len))))))
+
+;; Test "array" display hint.
+
+(define (make-array-printer val)
+ (let ((name (value-field val "name"))
+ (len (value-field val "len"))
+ (elements (value-field val "elements")))
+ (make-pretty-printer-worker
+ "array"
+ (lambda (printer)
+ (format #f "array ~A with ~A elements"
+ name len))
+ (lambda (printer)
+ (make-pointer-iterator elements (value->integer len))))))
+
+;; Flag to make no-string-container printer throw an exception.
+
+(define *exception-flag* #f)
+
+;; Test a printer where to_string returns #f.
+
+(define (make-no-string-container-printer val)
+ (let ((len (value-field val "len"))
+ (elements (value-field val "elements")))
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer) #f)
+ (lambda (printer)
+ (make-pointer-iterator-except elements (value->integer len))))))
+
+(define (make-pp_s-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (let ((a (value-field val "a"))
+ (b (value-field val "b")))
+ (if (not (value=? (value-address a) b))
+ (error (format #f "&a(~A) != b(~A)"
+ (value-address a) b)))
+ (format #f "a=<~A> b=<~A>" a b)))
+ #f))
+
+(define (make-pp_ss-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (let ((a (value-field val "a"))
+ (b (value-field val "b")))
+ (format #f "a=<~A> b=<~A>" a b)))
+ #f))
+
+(define (make-pp_sss-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (let ((a (value-field val "a"))
+ (b (value-field val "b")))
+ (format #f "a=<~A> b=<~A>" a b)))
+ #f))
+
+(define (make-pp_multiple_virtual-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (format #f "pp value variable is: ~A" (value-field val "value")))
+ #f))
+
+(define (make-pp_vbase1-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (format #f "pp class name: ~A" (type-tag (value-type val))))
+ #f))
+
+(define (make-pp_nullstr-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (value->string (value-field val "s")
+ #:encoding (arch-charset (current-arch))))
+ #f))
+
+(define (make-pp_ns-printer val)
+ (make-pretty-printer-worker
+ "string"
+ (lambda (printer)
+ (let ((len (value-field val "length")))
+ (value->string (value-field val "null_str")
+ #:encoding (arch-charset (current-arch))
+ #:length (value->integer len))))
+ #f))
+
+(define *pp-ls-encoding* #f)
+
+(define (make-pp_ls-printer val)
+ (make-pretty-printer-worker
+ "string"
+ (lambda (printer)
+ (if *pp-ls-encoding*
+ (value->lazy-string (value-field val "lazy_str")
+ #:encoding *pp-ls-encoding*)
+ (value->lazy-string (value-field val "lazy_str"))))
+ #f))
+
+(define (make-pp_hint_error-printer val)
+ "Use an invalid value for the display hint."
+ (make-pretty-printer-worker
+ 42
+ (lambda (printer) "hint_error_val")
+ #f))
+
+(define (make-pp_children_as_list-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer) "children_as_list_val")
+ (lambda (printer) (make-list-iterator (list (cons "one" 1))))))
+
+(define (make-pp_outer-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (format #f "x = ~A" (value-field val "x")))
+ (lambda (printer)
+ (make-list-iterator (list (cons "s" (value-field val "s"))
+ (cons "x" (value-field val "x")))))))
+
+(define (make-memory-error-string-printer val)
+ (make-pretty-printer-worker
+ "string"
+ (lambda (printer)
+ (scm-error 'gdb:memory-error "memory-error-printer"
+ "Cannot access memory." '() '()))
+ #f))
+
+(define (make-pp_eval_type-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (execute "bt" #:to-string #t)
+ (format #f "eval=<~A>"
+ (value-print
+ (parse-and-eval
+ "eval_func (123456789, 2, 3, 4, 5, 6, 7, 8)"))))
+ #f))
+
+(define (get-type-for-printing val)
+ "Return type of val, stripping away typedefs, etc."
+ (let ((type (value-type val)))
+ (if (= (type-code type) TYPE_CODE_REF)
+ (set! type (type-target type)))
+ (type-strip-typedefs (type-unqualified type))))
+
+(define (disable-matcher!)
+ (set-pretty-printer-enabled! *pretty-printer* #f))
+
+(define (enable-matcher!)
+ (set-pretty-printer-enabled! *pretty-printer* #t))
+
+(define (make-pretty-printer-dict)
+ (let ((dict (make-hash-table)))
+ (hash-set! dict "struct s" make-pp_s-printer)
+ (hash-set! dict "s" make-pp_s-printer)
+ (hash-set! dict "S" make-pp_s-printer)
+
+ (hash-set! dict "struct ss" make-pp_ss-printer)
+ (hash-set! dict "ss" make-pp_ss-printer)
+ (hash-set! dict "const S &" make-pp_s-printer)
+ (hash-set! dict "SSS" make-pp_sss-printer)
+
+ (hash-set! dict "VirtualTest" make-pp_multiple_virtual-printer)
+ (hash-set! dict "Vbase1" make-pp_vbase1-printer)
+
+ (hash-set! dict "struct nullstr" make-pp_nullstr-printer)
+ (hash-set! dict "nullstr" make-pp_nullstr-printer)
+
+ ;; Note that we purposely omit the typedef names here.
+ ;; Printer lookup is based on canonical name.
+ ;; However, we do need both tagged and untagged variants, to handle
+ ;; both the C and C++ cases.
+ (hash-set! dict "struct string_repr" make-string-printer)
+ (hash-set! dict "struct container" make-container-printer)
+ (hash-set! dict "struct justchildren" make-no-string-container-printer)
+ (hash-set! dict "string_repr" make-string-printer)
+ (hash-set! dict "container" make-container-printer)
+ (hash-set! dict "justchildren" make-no-string-container-printer)
+
+ (hash-set! dict "struct ns" make-pp_ns-printer)
+ (hash-set! dict "ns" make-pp_ns-printer)
+
+ (hash-set! dict "struct lazystring" make-pp_ls-printer)
+ (hash-set! dict "lazystring" make-pp_ls-printer)
+
+ (hash-set! dict "struct outerstruct" make-pp_outer-printer)
+ (hash-set! dict "outerstruct" make-pp_outer-printer)
+
+ (hash-set! dict "struct hint_error" make-pp_hint_error-printer)
+ (hash-set! dict "hint_error" make-pp_hint_error-printer)
+
+ (hash-set! dict "struct children_as_list"
+ make-pp_children_as_list-printer)
+ (hash-set! dict "children_as_list" make-pp_children_as_list-printer)
+
+ (hash-set! dict "memory_error" make-memory-error-string-printer)
+
+ (hash-set! dict "eval_type_s" make-pp_eval_type-printer)
+
+ dict))
+
+;; This is one way to register a printer that is composed of several
+;; subprinters, but there's no way to disable or list individual subprinters.
+
+(define *pretty-printer*
+ (make-pretty-printer
+ "pretty-printer-test"
+ (let ((pretty-printers-dict (make-pretty-printer-dict)))
+ (lambda (matcher val)
+ "Look-up and return a pretty-printer that can print val."
+ (let ((type (get-type-for-printing val)))
+ (let ((typename (type-tag type)))
+ (if typename
+ (let ((printer-maker (hash-ref pretty-printers-dict typename)))
+ (and printer-maker (printer-maker val)))
+ #f)))))))
+
+(append-pretty-printer! #f *pretty-printer*)
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2010-2014 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/>. */
+
+#include "symcat.h"
+#include "gdb/section-scripts.h"
+
+/* Put the path to the pretty-printer script in .debug_gdb_scripts so
+ gdb will automagically loaded it. */
+
+#define DEFINE_GDB_SCRIPT(script_name) \
+ asm("\
+.pushsection \".debug_gdb_scripts\", \"MS\",@progbits,1\n\
+.byte " XSTRING (SECTION_SCRIPT_ID_SCHEME_FILE) "\n\
+.asciz \"" script_name "\"\n\
+.popsection \n\
+");
+
+DEFINE_GDB_SCRIPT (SCRIPT_FILE)
+
+struct ss
+{
+ int a;
+ int b;
+};
+
+void
+init_ss (struct ss *s, int a, int b)
+{
+ s->a = a;
+ s->b = b;
+}
+
+int
+main ()
+{
+ struct ss ss;
+
+ init_ss (&ss, 1, 2);
+
+ return 0; /* break to inspect struct and union */
+}
--- /dev/null
+# Copyright (C) 2010-2014 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 automagic loading of
+# scripts specified in the .debug_gdb_scripts section.
+
+# This test can only be run on targets which support ELF and use gas.
+# For now pick a sampling of likely targets.
+if {![istarget *-*-linux*]
+ && ![istarget *-*-gnu*]
+ && ![istarget *-*-elf*]
+ && ![istarget *-*-openbsd*]
+ && ![istarget arm*-*-eabi*]
+ && ![istarget arm*-*-symbianelf*]
+ && ![istarget powerpc-*-eabi*]} {
+ verbose "Skipping scm-section-script.exp because of lack of support."
+ return
+}
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+# Make this available to gdb before the program starts, it is
+# automagically loaded by gdb.
+# Give the file a new name so we don't clobber the real one if
+# objfile == srcdir.
+# We also need to do this before compiling the program because the name
+# of the script file is encoded in the binary.
+# FIXME: Can we get gdb_remote_download to call standard_output_file for us?
+set remote_guile_file [gdb_remote_download host \
+ ${srcdir}/${subdir}/${testfile}.scm \
+ ${subdir}/t-${testfile}.scm]
+
+if {[build_executable $testfile.exp $testfile $srcfile \
+ [list debug "additional_flags=-I${srcdir}/../../include -DSCRIPT_FILE=\"$remote_guile_file\""]] == -1} {
+ return
+}
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_test_no_output "set auto-load safe-path ${remote_guile_file}" \
+ "set auto-load safe-path"
+gdb_load ${binfile}
+
+# Verify gdb loaded the script.
+gdb_test "info auto-load guile-scripts" "Yes.*${testfile}.scm.*"
+# Again, with a regexp this time.
+gdb_test "info auto-load guile-scripts ${testfile}" "Yes.*${testfile}.scm.*"
+# Again, with a regexp that matches no scripts.
+gdb_test "info auto-load guile-scripts no-script-matches-this" \
+ "No auto-load scripts matching no-script-matches-this."
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+gdb_test "b [gdb_get_line_number {break to inspect} ${testfile}.c ]" \
+ ".*Breakpoint.*"
+gdb_test "continue" ".*Breakpoint.*"
+
+gdb_test "print ss" " = a=<1> b=<2>"
--- /dev/null
+;; Copyright (C) 2010-2014 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.
+
+(use-modules (gdb) (gdb printing))
+
+(define (make-pp_ss-printer val)
+ (make-pretty-printer-worker
+ #f
+ (lambda (printer)
+ (let ((a (value-field val "a"))
+ (b (value-field val "b")))
+ (format #f "a=<~A> b=<~A>" a b)))
+ #f))
+
+(define (get-type-for-printing val)
+ "Return type of val, stripping away typedefs, etc."
+ (let ((type (value-type val)))
+ (if (= (type-code type) TYPE_CODE_REF)
+ (set! type (type-target type)))
+ (type-strip-typedefs (type-unqualified type))))
+
+(define (make-pretty-printer-dict)
+ (let ((dict (make-hash-table)))
+ (hash-set! dict "struct ss" make-pp_ss-printer)
+ (hash-set! dict "ss" make-pp_ss-printer)
+ dict))
+
+(define *pretty-printer*
+ (make-pretty-printer
+ "pretty-printer-test"
+ (let ((pretty-printers-dict (make-pretty-printer-dict)))
+ (lambda (matcher val)
+ "Look-up and return a pretty-printer that can print val."
+ (let ((type (get-type-for-printing val)))
+ (let ((typename (type-tag type)))
+ (if typename
+ (let ((printer-maker (hash-ref pretty-printers-dict typename)))
+ (and printer-maker (printer-maker val)))
+ #f)))))))
+
+(append-pretty-printer! #f *pretty-printer*)
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2010-2014 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/>. */
+
+#ifdef __cplusplus
+class SimpleClass
+{
+ private:
+ int i;
+
+ public:
+ void seti (int arg)
+ {
+ i = arg;
+ }
+
+ int valueofi (void)
+ {
+ return i; /* Break in class. */
+ }
+};
+#endif
+
+int qq = 72; /* line of qq */
+
+int func (int arg)
+{
+ int i = 2;
+ i = i * arg; /* Block break here. */
+ return arg;
+}
+
+struct simple_struct
+{
+ int a;
+};
+
+int main (int argc, char *argv[])
+{
+#ifdef __cplusplus
+ SimpleClass sclass;
+#endif
+ int a = 0;
+ int result;
+ struct simple_struct ss = { 10 };
+ enum tag {one, two, three};
+ enum tag t = one;
+
+ result = func (42);
+
+#ifdef __cplusplus
+ sclass.seti (42);
+ sclass.valueofi ();
+#endif
+ return 0; /* Break at end. */
+}
--- /dev/null
+# Copyright (C) 2010-2014 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 exposing symbols to Guile.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+if {[prepare_for_testing $testfile.exp $testfile $srcfile debug]} {
+ return -1
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+# These tests are done before we call gdb_guile_runto_main so we have to
+# import the gdb module ourselves.
+gdb_install_guile_utils
+gdb_install_guile_module
+
+# Test looking up a global symbol before we runto_main as this is the
+# point where we don't have a current frame, and we don't want to
+# require one.
+gdb_scm_test_silent_cmd "guile (define main-func (lookup-global-symbol \"main\"))" \
+ "lookup main"
+gdb_test "guile (print (symbol-function? main-func))" \
+ "= #t" "test (symbol-function? main)"
+gdb_test "guile (print (lookup-global-symbol \"junk\"))" \
+ "= #f" "test (lookup-global-symbol junk)"
+
+gdb_test "guile (print (symbol-value main-func))" \
+ "= {int \\(int, char \[*\]\[*\]\\)} $hex \\<main\\>" "print value of main"
+
+set qq_line [gdb_get_line_number "line of qq"]
+gdb_scm_test_silent_cmd "guile (define qq-var (lookup-global-symbol \"qq\"))" \
+ "lookup qq"
+gdb_test "guile (print (symbol-line qq-var))" \
+ "= $qq_line" "print line number of qq"
+gdb_test "guile (print (symbol-value qq-var))" \
+ "= 72" "print value of qq"
+gdb_test "guile (print (symbol-needs-frame? qq-var))" \
+ "= #f" "print whether qq needs a frame"
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+# Test symbol eq? and equal?.
+gdb_test "guile (print (eq? (lookup-global-symbol \"main\") (lookup-global-symbol \"main\")))" \
+ "= #t"
+gdb_test "guile (print (equal? (lookup-global-symbol \"main\") (lookup-global-symbol \"main\")))" \
+ "= #t"
+
+gdb_breakpoint [gdb_get_line_number "Block break here."]
+gdb_continue_to_breakpoint "Block break here."
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
+ "get frame at block break"
+gdb_scm_test_silent_cmd "guile (define block (frame-block frame))" \
+ "get block at block break"
+
+# Test symbol-argument?.
+gdb_scm_test_silent_cmd "guile (define arg (car (lookup-symbol \"arg\")))" \
+ "get variable arg"
+gdb_test "guile (print (symbol-variable? arg))" "= #f"
+gdb_test "guile (print (symbol-constant? arg))" "= #f"
+gdb_test "guile (print (symbol-argument? arg))" "= #t"
+gdb_test "guile (print (symbol-function? arg))" "= #f"
+
+# Test symbol-function?.
+gdb_scm_test_silent_cmd "guile (define func (block-function block))" \
+ "get block function"
+gdb_test "guile (print (symbol-variable? func))" "= #f"
+gdb_test "guile (print (symbol-constant? func))" "= #f"
+gdb_test "guile (print (symbol-argument? func))" "= #f"
+gdb_test "guile (print (symbol-function? func))" "= #t"
+
+# Test attributes of func.
+gdb_test "guile (print (symbol-name func))" "func"
+gdb_test "guile (print (symbol-print-name func))" "func"
+gdb_test "guile (print (symbol-linkage-name func))" "func"
+gdb_test "guile (print (= (symbol-addr-class func) SYMBOL_LOC_BLOCK))" "= #t"
+
+gdb_breakpoint [gdb_get_line_number "Break at end."]
+gdb_continue_to_breakpoint "Break at end."
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
+ "get frame at end"
+
+# Test symbol-variable?.
+gdb_scm_test_silent_cmd "guile (define a (car (lookup-symbol \"a\")))" \
+ "get variable a"
+gdb_test "guile (print (symbol-variable? a))" "= #t"
+gdb_test "guile (print (symbol-constant? a))" "= #f"
+gdb_test "guile (print (symbol-argument? a))" "= #f"
+gdb_test "guile (print (symbol-function? a))" "= #f"
+
+# Test attributes of a.
+gdb_test "guile (print (= (symbol-addr-class a) SYMBOL_LOC_COMPUTED))" "= #t"
+
+gdb_test "guile (print (symbol-value a))" \
+ "ERROR: Symbol requires a frame to compute its value.*"\
+ "try to print value of a without a frame"
+gdb_test "guile (print (symbol-value a #:frame frame))" \
+ "= 0" "print value of a"
+gdb_test "guile (print (symbol-needs-frame? a))" \
+ "= #t" "print whether a needs a frame"
+
+# Test symbol-constant?.
+gdb_scm_test_silent_cmd "guile (define t (car (lookup-symbol \"one\")))" \
+ "get constant t"
+gdb_test "guile (print (symbol-variable? t))" "= #f"
+gdb_test "guile (print (symbol-constant? t))" "= #t"
+gdb_test "guile (print (symbol-argument? t))" "= #f"
+gdb_test "guile (print (symbol-function? t))" "= #f"
+
+# Test attributes of t.
+gdb_test "guile (print (= (symbol-addr-class t) SYMBOL_LOC_CONST))" "= #t"
+
+# Test type attribute.
+gdb_test "guile (print (symbol-type t))" "= enum tag"
+
+# Test symtab attribute.
+gdb_test "guile (print (symbol-symtab t))" "= #<gdb:symtab .*gdb.guile/scm-symbol.c>"
+
+# C++ tests
+# Recompile binary.
+if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${binfile}-cxx" executable "debug c++"] != "" } {
+ untested "Couldn't compile ${srcfile} in c++ mode"
+ return -1
+}
+
+# Start with a fresh gdb.
+gdb_exit
+gdb_start
+gdb_reinitialize_dir $srcdir/$subdir
+gdb_load ${binfile}-cxx
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+gdb_breakpoint [gdb_get_line_number "Break in class."]
+gdb_continue_to_breakpoint "Break in class."
+
+gdb_scm_test_silent_cmd "guile (define cplusframe (selected-frame))" \
+ "get frame at class"
+gdb_scm_test_silent_cmd "guile (define cplusfunc (block-function (frame-block cplusframe)))" \
+ "get function at class"
+
+gdb_test "guile (print (symbol-variable? cplusfunc))" "= #f"
+gdb_test "guile (print (symbol-constant? cplusfunc))" "= #f"
+gdb_test "guile (print (symbol-argument? cplusfunc))" "= #f"
+gdb_test "guile (print (symbol-function? cplusfunc))" "= #t"
+
+gdb_test "guile (print (symbol-name cplusfunc))" \
+ "= SimpleClass::valueofi().*" "test method.name"
+gdb_test "guile (print (symbol-print-name cplusfunc))" \
+ "= SimpleClass::valueofi().*" "test method.print_name"
+# FIXME: GDB is broken here and we're verifying broken behaviour.
+# (linkage-name should be the mangled name)
+gdb_test "guile (print (symbol-linkage-name cplusfunc))" \
+ "SimpleClass::valueofi().*" "test method.linkage_name"
+gdb_test "guile (print (= (symbol-addr-class cplusfunc) SYMBOL_LOC_BLOCK))" "= #t"
+
+# Test is_valid when the objfile is unloaded. This must be the last
+# test as it unloads the object file in GDB.
+# Start with a fresh gdb.
+clean_restart ${testfile}
+if ![gdb_guile_runto_main] {
+ return
+}
+
+gdb_breakpoint [gdb_get_line_number "Break at end."]
+gdb_continue_to_breakpoint "Break at end."
+gdb_scm_test_silent_cmd "guile (define a (car (lookup-symbol \"a\")))" \
+ "get variable a for unload"
+gdb_test "guile (print (symbol-valid? a))" \
+ "= #t" "test symbol validity pre-unload"
+delete_breakpoints
+gdb_unload
+gdb_test "guile (print (symbol-valid? a))" \
+ "= #f" "test symbol validity post-unload"
+gdb_test_no_output "guile (set! a #f) (gc)" "test symbol destructor"
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2010-2014 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/>. */
+
+void
+func1 ()
+{
+ return;
+}
+
+int
+func2 ()
+{
+ return 0;
+}
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2010-2014 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/>. */
+
+/* In scm-symtab-2.c. */
+extern void func1 (void);
+extern int func2 (void);
+
+struct simple_struct
+{
+ int a;
+};
+
+struct simple_struct qq;
+
+int
+func (int arg)
+{
+ int i = 2;
+ i = i * arg; /* Block break here. */
+ return arg;
+}
+
+int
+main (int argc, char *argv[])
+{
+ qq.a = func (42);
+
+ func1 ();
+ func2 (); /* Break at func2 call site. */
+ return 0; /* Break to end. */
+}
--- /dev/null
+# Copyright (C) 2010-2014 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 Guile symbol table support.
+
+load_lib gdb-guile.exp
+
+standard_testfile scm-symtab.c scm-symtab-2.c
+
+if {[prepare_for_testing $testfile.exp $testfile \
+ [list $srcfile $srcfile2] debug]} {
+ return
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+# Setup and get the symbol table.
+set line_no [gdb_get_line_number "Block break here."]
+gdb_breakpoint $line_no
+gdb_continue_to_breakpoint "Block break here."
+gdb_scm_test_silent_cmd "guile (define frame (selected-frame))" \
+ "get frame"
+gdb_scm_test_silent_cmd "guile (define sal (frame-sal frame))" \
+ "get sal"
+gdb_scm_test_silent_cmd "guile (define symtab (sal-symtab sal))" \
+ "get symtab"
+gdb_scm_test_silent_cmd "guile (define global-block (symtab-global-block symtab))" \
+ "get global block"
+gdb_scm_test_silent_cmd "guile (define static-block (symtab-static-block symtab))" \
+ "get static block"
+
+gdb_scm_test_silent_cmd "guile (define global-symbols (map symbol-name (block-symbols global-block)))" \
+ "get global symbol names"
+gdb_scm_test_silent_cmd "guile (define static-symbols (map symbol-name (block-symbols static-block)))" \
+ "get static symbol names"
+gdb_scm_test_silent_cmd "guile (define global-isymbols '()) (define static-isymbols '())" \
+ "set up iterated symbol name lists"
+# TODO: iterated symbols
+gdb_scm_test_silent_cmd "step" "Step to the next line"
+gdb_scm_test_silent_cmd "guile (define new-pc (sal-pc (frame-sal (selected-frame))))" \
+ "get new pc"
+
+# Test sal.
+gdb_test "guile (print (sal-symtab sal))" \
+ ".*gdb.guile/scm-symtab.c.*" "Test sal-symtab"
+gdb_test "guile (print (sal-pc sal))" \
+ "${decimal}" "test sal-pc"
+gdb_test "guile (print (= (sal-last sal) (- new-pc 1)))" \
+ "#t" "test sal-last"
+gdb_test "guile (print (sal-line sal))" \
+ "$line_no" "test sal-line"
+gdb_test "guile (print (sal-valid? sal))" \
+ "#t" "test sal-valid?"
+
+# Test eq? on symtabs.
+gdb_scm_test_silent_cmd "guile (define sal1 (frame-sal frame))" \
+ "get sal1"
+gdb_scm_test_silent_cmd "guile (define sal2 (frame-sal (frame-older frame)))" \
+ "get sal2"
+gdb_test "guile (print (eq? symtab (sal-symtab sal1)))" \
+ "= #t" "test eq? of equal symtabs"
+gdb_test "guile (print (eq? symtab (sal-symtab sal2)))" \
+ "= #t" "test eq? of equal symtabs from different sals"
+gdb_test "guile (print (eq? symtab (symbol-symtab (lookup-global-symbol \"func1\"))))" \
+ "= #f" "test eq? of not-equal symtabs"
+
+# Test symbol table.
+gdb_test "guile (print (symtab-filename symtab))" \
+ ".*gdb.guile/scm-symtab.c.*" "test symtab-filename"
+gdb_test "guile (print (symtab-objfile symtab))" \
+ "#<gdb:objfile .*scm-symtab>" "test symtab-objfile"
+gdb_test "guile (print (symtab-fullname symtab))" \
+ "testsuite/gdb.guile/scm-symtab.c.*" "test symtab-fullname"
+gdb_test "guile (print (symtab-valid? symtab))" \
+ "#t" "test symtab-valid?"
+gdb_test "guile (print (->bool (member \"qq\" global-symbols)))" \
+ "#t" "test qq in global symbols"
+gdb_test "guile (print (->bool (member \"func\" global-symbols)))" \
+ "#t" "test func in global symbols"
+gdb_test "guile (print (->bool (member \"main\" global-symbols)))" \
+ "#t" "test main in global symbols"
+gdb_test "guile (print (->bool (member \"int\" static-symbols)))" \
+ "#t" "test int in static symbols"
+gdb_test "guile (print (->bool (member \"char\" static-symbols)))" \
+ "#t" "test char in static symbols"
+gdb_test "guile (print (->bool (member \"simple_struct\" static-symbols)))" \
+ "#t" "test simple_struct in static symbols"
+
+# Test is_valid when the objfile is unloaded. This must be the last
+# test as it unloads the object file in GDB.
+gdb_unload
+gdb_test "guile (print (sal-valid? sal))" \
+ "#f" "test sal-valid? after unloading"
+gdb_test "guile (print (symtab-valid? symtab))" \
+ "#f" "test symtab-valid? after unloading"
+
+gdb_test_no_output "guile (set! sal #f)" \
+ "test sal destructor"
+gdb_test_no_output "guile (set! symtab #f)" \
+ "test symtab destructor"
+gdb_test_no_output "guile (gc)" "GC to trigger destructors"
+
+# Start with a fresh gdb.
+clean_restart ${testfile}
+
+# Test find-pc-line.
+# The following tests require execution.
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+runto [gdb_get_line_number "Break at func2 call site."]
+
+gdb_scm_test_silent_cmd "guile (define line (sal-line (frame-sal (selected-frame))))" \
+ "get line number of func2 call site"
+gdb_test "guile (print (= (sal-line (find-pc-line (frame-pc (selected-frame)))) line))" \
+ "#t" "test find-pc-line at func2 call site"
+
+gdb_scm_test_silent_cmd "step" "step into func2"
+gdb_scm_test_silent_cmd "up" "step out of func2"
+
+gdb_test "guile (print (> (sal-line (find-pc-line (frame-pc (selected-frame)))) line))" \
+ "#t" "test find-pc-line with resume address"
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2009-2014 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 s
+{
+ int a;
+ int b;
+};
+
+typedef struct s TS;
+TS ts;
+
+#ifdef __cplusplus
+struct C
+{
+ int c;
+ int d;
+};
+
+struct D : C
+{
+ int e;
+ int f;
+};
+
+template<typename T, int I, int C::*MP>
+struct Temargs
+{
+};
+
+Temargs<D, 23, &C::c> temvar;
+
+#endif
+
+enum E
+{ v1, v2, v3
+};
+
+struct s vec_data_1 = {1, 1};
+struct s vec_data_2 = {1, 2};
+
+int
+main ()
+{
+ int ar[2] = {1,2};
+ struct s st;
+#ifdef __cplusplus
+ C c;
+ c.c = 1;
+ c.d = 2;
+ D d;
+ d.e = 3;
+ d.f = 4;
+#endif
+ enum E e;
+
+ st.a = 3;
+ st.b = 5;
+
+ e = v2;
+
+ return 0; /* break to inspect struct and array. */
+}
--- /dev/null
+# Copyright (C) 2009-2014 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 of exposing types to Guile.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+if [get_compiler_info c++] {
+ return -1
+}
+
+# Build inferior to language specification.
+
+proc build_inferior {exefile lang} {
+ global srcdir subdir srcfile
+
+ if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${exefile}" executable "debug $lang"] != "" } {
+ untested "Couldn't compile ${srcfile} in $lang mode"
+ return -1
+ }
+ return 0
+}
+
+# Restart GDB.
+# The result is the same as gdb_guile_runto_main.
+
+proc restart_gdb {exefile} {
+ global srcdir subdir
+
+ gdb_exit
+ gdb_start
+ gdb_reinitialize_dir $srcdir/$subdir
+ gdb_load ${exefile}
+
+ if { [skip_guile_tests] } {
+ return 0
+ }
+
+ if ![gdb_guile_runto_main] {
+ return 0
+ }
+ gdb_scm_test_silent_cmd "guile (use-modules (gdb iterator))" \
+ "load iterator module"
+
+ return 1
+}
+
+# Set breakpoint and run to that breakpoint.
+
+proc runto_bp {bp} {
+ gdb_breakpoint [gdb_get_line_number $bp]
+ gdb_continue_to_breakpoint $bp
+}
+
+proc test_fields {lang} {
+ with_test_prefix "test_fields" {
+ global gdb_prompt
+
+ # fields of a typedef should still return the underlying field list
+ gdb_test "guile (print (length (type-fields (value-type (parse-and-eval \"ts\")))))" \
+ "= 2" "$lang typedef field list"
+
+ if {$lang == "c++"} {
+ # Test usage with a class.
+ gdb_scm_test_silent_cmd "print c" "print value (c)"
+ gdb_scm_test_silent_cmd "guile (define c (history-ref 0))" \
+ "get value (c) from history"
+ gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type c)))" \
+ "get fields from c type"
+ gdb_test "guile (print (length fields))" \
+ "= 2" "check number of fields of c"
+ gdb_test "guile (print (field-name (car fields)))" \
+ "= c" "check class field c name"
+ gdb_test "guile (print (field-name (cadr fields)))" \
+ "= d" "check class field d name"
+ }
+
+ # Test normal fields usage in structs.
+ gdb_scm_test_silent_cmd "print st" "print value (st)"
+ gdb_scm_test_silent_cmd "guile (define st (history-ref 0))" \
+ "get value (st) from history"
+ gdb_scm_test_silent_cmd "guile (define st-type (value-type st))" \
+ "get st-type"
+ gdb_scm_test_silent_cmd "guile (define fields (type-fields st-type))" \
+ "get fields from st.type"
+ gdb_test "guile (print (length fields))" \
+ "= 2" "check number of fields (st)"
+ gdb_test "guile (print (field-name (car fields)))" \
+ "= a" "check structure field a name"
+ gdb_test "guile (print (field-name (cadr fields)))" \
+ "= b" "check structure field b name"
+ gdb_test "guile (print (field-name (type-field st-type \"a\")))" \
+ "= a" "check fields lookup by name"
+
+ # Test has-field?
+ gdb_test "guile (print (type-has-field? st-type \"b\"))" \
+ "= #t" "check existent field"
+ gdb_test "guile (print (type-has-field? st-type \"nosuch\"))" \
+ "= #f" "check non-existent field"
+
+ # Test Guile mapping behavior of gdb:type for structs/classes.
+ gdb_test "guile (print (type-num-fields (value-type st)))" \
+ "= 2" "check number of fields (st) with type-num-fields"
+ gdb_scm_test_silent_cmd "guile (define fi (make-field-iterator st-type))" \
+ "create field iterator"
+ gdb_test "guile (print (iterator-map field-bitpos fi))" \
+ "= \\(0 32\\)" "check field iterator"
+
+ # Test rejection of mapping operations on scalar types.
+ gdb_test "guile (print (make-field-iterator (field-type (type-field st-type \"a\"))))" \
+ "ERROR: .*: Out of range: type is not a structure, union, or enum type in position 1: .*" \
+ "check field iterator on bad type"
+
+ # Test type-array.
+ gdb_scm_test_silent_cmd "print ar" "print value (ar)"
+ gdb_scm_test_silent_cmd "guile (define ar (history-ref 0))" \
+ "get value (ar) from history"
+ gdb_scm_test_silent_cmd "guile (define ar0 (value-subscript ar 0))" \
+ "define ar0"
+ gdb_test "guile (print (value-cast ar0 (type-array (value-type ar0) 1)))" \
+ "= \\{1, 2\\}" "cast to array with one argument"
+ gdb_test "guile (print (value-cast ar0 (type-array (value-type ar0) 0 1)))" \
+ "= \\{1, 2\\}" "cast to array with two arguments"
+
+ # Test type-vector.
+ # Note: vectors cast differently than arrays. Here ar[0] is replicated
+ # for the size of the vector.
+ gdb_scm_test_silent_cmd "print vec_data_1" "print value (vec_data_1)"
+ gdb_scm_test_silent_cmd "guile (define vec_data_1 (history-ref 0))" \
+ "get value (vec_data_1) from history"
+
+ gdb_scm_test_silent_cmd "print vec_data_2" "print value (vec_data_2)"
+ gdb_scm_test_silent_cmd "guile (define vec_data_2 (history-ref 0))" \
+ "get value (vec_data_2) from history"
+
+ gdb_scm_test_silent_cmd "guile (define vec1 (value-cast vec_data_1 (type-vector (value-type ar0) 1)))" \
+ "set vec1"
+ gdb_test "guile (print vec1)" \
+ "= \\{1, 1\\}" "cast to vector with one argument"
+ gdb_scm_test_silent_cmd "guile (define vec2 (value-cast vec_data_1 (type-vector (value-type ar0) 0 1)))" \
+ "set vec2"
+ gdb_test "guile (print vec2)" \
+ "= \\{1, 1\\}" "cast to vector with two arguments"
+ gdb_test "guile (print (value=? vec1 vec2))" \
+ "= #t"
+ gdb_scm_test_silent_cmd "guile (define vec3 (value-cast vec_data_2 (type-vector (value-type ar0) 1)))" \
+ "set vec3"
+ gdb_test "guile (print (value=? vec1 vec3))" \
+ "= #f"
+ }
+}
+
+proc test_equality {lang} {
+ with_test_prefix "test_equality" {
+ gdb_scm_test_silent_cmd "guile (define st (parse-and-eval \"st\"))" \
+ "get st"
+ gdb_scm_test_silent_cmd "guile (define ar (parse-and-eval \"ar\"))" \
+ "get ar"
+ gdb_test "guile (print (eq? (value-type st) (value-type st)))" \
+ "= #t" "test type eq? on equal types"
+ gdb_test "guile (print (eq? (value-type st) (value-type ar)))" \
+ "= #f" "test type eq? on not-equal types"
+ gdb_test "guile (print (equal? (value-type st) (value-type st)))" \
+ "= #t" "test type eq? on equal types"
+ gdb_test "guile (print (equal? (value-type st) (value-type ar)))" \
+ "= #f" "test type eq? on not-equal types"
+
+ if {$lang == "c++"} {
+ gdb_scm_test_silent_cmd "guile (define c (parse-and-eval \"c\"))" \
+ "get c"
+ gdb_scm_test_silent_cmd "guile (define d (parse-and-eval \"d\"))" \
+ "get d"
+ gdb_test "guile (print (eq? (value-type c) (field-type (car (type-fields (value-type d))))))" \
+ "= #t" "test c++ type eq? on equal types"
+ gdb_test "guile (print (eq? (value-type c) (value-type d)))" \
+ "= #f" "test c++ type eq? on not-equal types"
+ gdb_test "guile (print (equal? (value-type c) (field-type (car (type-fields (value-type d))))))" \
+ "= #t" "test c++ type equal? on equal types"
+ gdb_test "guile (print (equal? (value-type c) (value-type d)))" \
+ "= #f" "test c++ type equal? on not-equal types"
+ }
+ }
+}
+
+proc test_enums {} {
+ with_test_prefix "test_enum" {
+ gdb_scm_test_silent_cmd "print e" "print value (e)"
+ gdb_scm_test_silent_cmd "guile (define e (history-ref 0))" \
+ "get value (e) from history"
+ gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type e)))" \
+ "extract type fields from e"
+ gdb_test "guile (print (length fields))" \
+ "= 3" "check the number of enum fields"
+ gdb_test "guile (print (field-name (car fields)))" \
+ "= v1" "check enum field\[0\] name"
+ gdb_test "guile (print (field-name (cadr fields)))" \
+ "= v2" "check enum field\[1\]name"
+
+ # Ditto but by mapping operations.
+ gdb_test "guile (print (type-num-fields (value-type e)))" \
+ "= 3" "check the number of enum values"
+ gdb_test "guile (print (field-name (type-field (value-type e) \"v1\")))" \
+ "= v1" "check enum field lookup by name (v1)"
+ gdb_test "guile (print (field-name (type-field (value-type e) \"v3\")))" \
+ "= v3" "check enum field lookup by name (v3)"
+ gdb_test "guile (print (iterator-map field-enumval (make-field-iterator (value-type e))))" \
+ "\\(0 1 2\\)" "check enum fields iteration"
+ }
+}
+
+proc test_base_class {} {
+ with_test_prefix "test_base_class" {
+ gdb_scm_test_silent_cmd "print d" "print value (d)"
+ gdb_scm_test_silent_cmd "guile (define d (history-ref 0))" \
+ "get value (d) from history"
+ gdb_scm_test_silent_cmd "guile (define fields (type-fields (value-type d)))" \
+ "extract type fields from d"
+ gdb_test "guile (print (length fields))" \
+ "= 3" "check the number of fields"
+ gdb_test "guile (print (field-baseclass? (car fields)))" \
+ "= #t" "check base class (fields\[0\])"
+ gdb_test "guile (print (field-baseclass? (cadr fields)))" \
+ "= #f" "check base class (fields\[1\])"
+ }
+}
+
+proc test_range {} {
+ with_test_prefix "test_range" {
+ with_test_prefix "on ranged value" {
+ # Test a valid range request.
+ gdb_scm_test_silent_cmd "print ar" "print value (ar)"
+ gdb_scm_test_silent_cmd "guile (define ar (history-ref 0))" \
+ "get value (ar) from history"
+ gdb_test "guile (print (length (type-range (value-type ar))))" \
+ "= 2" "check correct tuple length"
+ gdb_test "guile (print (type-range (value-type ar)))" \
+ "= \\(0 1\\)" "check range"
+ }
+
+ with_test_prefix "on unranged value" {
+ # Test where a range does not exist.
+ gdb_scm_test_silent_cmd "print st" "print value (st)"
+ gdb_scm_test_silent_cmd "guile (define st (history-ref 0))" \
+ "get value (st) from history"
+ gdb_test "guile (print (type-range (value-type st)))" \
+ "ERROR: .*: Wrong type argument in position 1 \\(expecting ranged type\\): .*" \
+ "check range for non ranged type"
+ }
+ }
+}
+
+# Perform C Tests.
+
+if { [build_inferior "${binfile}" "c"] < 0 } {
+ return
+}
+if ![restart_gdb "${binfile}"] {
+ return
+}
+
+with_test_prefix "lang_c" {
+ runto_bp "break to inspect struct and array."
+ test_fields "c"
+ test_equality "c"
+ test_enums
+}
+
+# Perform C++ Tests.
+
+if { [build_inferior "${binfile}-cxx" "c++"] < 0 } {
+ return
+}
+if ![restart_gdb "${binfile}-cxx"] {
+ return
+}
+
+with_test_prefix "lang_cpp" {
+ runto_bp "break to inspect struct and array."
+ test_fields "c++"
+ test_base_class
+ test_range
+ test_equality "c++"
+ test_enums
+}
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2012-2014 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/>. */
+
+class A {
+};
+
+typedef int *int_ptr;
+
+int
+func (const A &a)
+{
+ int val = 10;
+ int &int_ref = val;
+ int_ptr ptr = &val;
+ int_ptr &int_ptr_ref = ptr;
+
+ return 0; /* Break here. */
+}
+
+int
+main ()
+{
+ A obj;
+ return func (obj);
+}
--- /dev/null
+# Copyright (C) 2012-2014 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 exposing c++ values to Guile.
+
+load_lib gdb-guile.exp
+
+if { [skip_cplus_tests] } { continue }
+
+standard_testfile .cc
+
+if {[prepare_for_testing $testfile.exp $testfile $srcfile {debug c++}]} {
+ return
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+gdb_breakpoint [gdb_get_line_number "Break here."]
+gdb_continue_to_breakpoint "Break here" ".*Break here.*"
+
+gdb_test "gu (print (value-type (parse-and-eval \"a\")))" \
+ "= const A &"
+gdb_test "gu (print (value-type (value-referenced-value (parse-and-eval \"a\"))))" \
+ "= const A"
+gdb_test "gu (print (value-type (parse-and-eval \"int_ref\")))" \
+ "= int &"
+gdb_test "gu (print (value-type (value-referenced-value (parse-and-eval \"int_ref\"))))" \
+ "= int"
+gdb_test "gu (print (value-referenced-value (parse-and-eval \"int_ref\")))" \
+ "= 10"
+
+gdb_test "gu (print (value-type (value-dereference (parse-and-eval \"int_ptr_ref\"))))" \
+ "= int"
+gdb_test "gu (print (value-type (value-referenced-value (parse-and-eval \"int_ptr_ref\"))))" \
+ "= int_ptr"
+gdb_test "gu (print (value-dereference (value-referenced-value (parse-and-eval \"int_ptr_ref\"))))" \
+ "= 10"
+gdb_test "gu (print (value-referenced-value (value-referenced-value (parse-and-eval \"int_ptr_ref\"))))" \
+ "= 10"
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2008-2014 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/>. */
+
+#include <stdio.h>
+
+struct s
+{
+ int a;
+ int b;
+};
+
+union u
+{
+ int a;
+ float b;
+};
+
+enum e
+ {
+ ONE = 1,
+ TWO = 2
+ };
+
+typedef struct s *PTR;
+
+enum e evalue = TWO;
+
+#ifdef __cplusplus
+
+struct Base {
+ virtual int x() { return 5; }
+};
+
+struct Derived : public Base {
+};
+
+Base *base = new Derived ();
+
+void ptr_ref(int*& rptr_int)
+{
+ return; /* break to inspect pointer by reference. */
+}
+#endif
+
+void func1 ()
+{
+ printf ("void function called\n");
+}
+
+int func2 (int arg1, int arg2)
+{
+ return arg1 + arg2;
+}
+
+char **save_argv;
+
+int
+main (int argc, char *argv[])
+{
+ char *cp = argv[0]; /* Prevent gcc from optimizing argv[] out. */
+ struct s s;
+ union u u;
+ PTR x = &s;
+ char st[17] = "divide et impera";
+ char nullst[17] = "divide\0et\0impera";
+ void (*fp1) (void) = &func1;
+ int (*fp2) (int, int) = &func2;
+ const char *sptr = "pointer";
+ const char *embed = "embedded x\201\202\203\204";
+ int a[3] = {1,2,3};
+ int *p = a;
+ int i = 2;
+ int *ptr_i = &i;
+ const char *sn = 0;
+ s.a = 3;
+ s.b = 5;
+ u.a = 7;
+ (*fp1) ();
+ (*fp2) (10,20);
+
+#ifdef __cplusplus
+ ptr_ref(ptr_i);
+#endif
+
+ save_argv = argv; /* break to inspect struct and union */
+ return 0;
+}
--- /dev/null
+# Copyright (C) 2008-2014 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 exposing values to Guile.
+
+load_lib gdb-guile.exp
+
+standard_testfile
+
+# Build inferior to language specification.
+# LANG is one of "c" or "c++".
+proc build_inferior {exefile lang} {
+ global srcdir subdir srcfile testfile hex
+
+ # Use different names for .o files based on the language.
+ # For Fission, the debug info goes in foo.dwo and we don't want,
+ # for example, a C++ compile to clobber the dwo of a C compile.
+ # ref: http://gcc.gnu.org/wiki/DebugFission
+ switch ${lang} {
+ "c" { set filename ${testfile}.o }
+ "c++" { set filename ${testfile}-cxx.o }
+ }
+ set objfile [standard_output_file $filename]
+
+ if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${objfile}" object "debug $lang"] != ""
+ || [gdb_compile "${objfile}" "${exefile}" executable "debug $lang"] != "" } {
+ untested "Couldn't compile ${srcfile} in $lang mode"
+ return -1
+ }
+ return 0
+}
+
+proc test_value_in_inferior {} {
+ global gdb_prompt
+ global testfile
+
+ gdb_breakpoint [gdb_get_line_number "break to inspect struct and union"]
+
+ gdb_continue_to_breakpoint "break to inspect struct and union"
+
+ # Just get inferior variable s in the value history, available to guile.
+ gdb_test "print s" "= {a = 3, b = 5}" ""
+
+ gdb_scm_test_silent_cmd "gu (define s (history-ref 0))" "set s"
+
+ gdb_test "gu (print (value-field s \"a\"))" \
+ "= 3" "access element inside struct using string name"
+
+ # Test dereferencing the argv pointer.
+
+ # Just get inferior variable argv the value history, available to guile.
+ gdb_test "print argv" "= \\(char \\*\\*\\) 0x.*" ""
+
+ gdb_scm_test_silent_cmd "gu (define argv (history-ref 0))" \
+ "set argv"
+ gdb_scm_test_silent_cmd "gu (define arg0 (value-dereference argv))" \
+ "set arg0"
+
+ # Check that the dereferenced value is sane.
+ if { ! [target_info exists noargs] } {
+ gdb_test "gu (print arg0)" \
+ "0x.*$testfile\"" "verify dereferenced value"
+ }
+
+ # Smoke-test value-optimized-out?.
+ gdb_test "gu (print (value-optimized-out? arg0))" \
+ "= #f" "Test value-optimized-out?"
+
+ # Test address attribute.
+ gdb_test "gu (print (value-address arg0))" \
+ "= 0x\[\[:xdigit:\]\]+" "Test address attribute"
+ # Test address attribute is #f in a non-addressable value.
+ gdb_test "gu (print (value-address (make-value 42)))" \
+ "= #f" "Test address attribute in non-addressable value"
+
+ # Test displaying a variable that is temporarily at a bad address.
+ # But if we can examine what's at memory address 0, then we'll also be
+ # able to display it without error. Don't run the test in that case.
+ set can_read_0 0
+ gdb_test_multiple "x 0" "memory at address 0" {
+ -re "0x0:\[ \t\]*Cannot access memory at address 0x0\r\n$gdb_prompt $" { }
+ -re "0x0:\[ \t\]*Error accessing memory address 0x0\r\n$gdb_prompt $" { }
+ -re "\r\n$gdb_prompt $" {
+ set can_read_0 1
+ }
+ }
+
+ # Test memory error.
+ set test "parse_and_eval with memory error"
+ if {$can_read_0} {
+ untested $test
+ } else {
+ gdb_test "gu (print (parse-and-eval \"*(int*)0\"))" \
+ "ERROR: Cannot access memory at address 0x0.*" $test
+ }
+
+ # Test Guile lazy value handling
+ set test "memory error and lazy values"
+ if {$can_read_0} {
+ untested $test
+ } else {
+ gdb_test_no_output "gu (define inval (parse-and-eval \"*(int*)0\"))"
+ gdb_test "gu (print (value-lazy? inval))" \
+ "#t"
+ gdb_test "gu (define inval2 (value-add inval 1))" \
+ "ERROR: Cannot access memory at address 0x0.*" $test
+ gdb_test "gu (value-fetch-lazy! inval))" \
+ "ERROR: Cannot access memory at address 0x0.*" $test
+ }
+ gdb_test_no_output "gu (define argc-lazy (parse-and-eval \"argc\"))"
+ gdb_test_no_output "gu (define argc-notlazy (parse-and-eval \"argc\"))"
+ gdb_test_no_output "gu (value-fetch-lazy! argc-notlazy)"
+ gdb_test "gu (print (value-lazy? argc-lazy))" "= #t"
+ gdb_test "gu (print (value-lazy? argc-notlazy))" "= #f"
+ gdb_test "print argc" "= 1" "sanity check argc"
+ gdb_test "gu (print (value-lazy? argc-lazy))" "= #t"
+ gdb_test_no_output "set argc=2"
+ gdb_test "gu (print argc-notlazy)" "= 1"
+ gdb_test "gu (print argc-lazy)" "= 2"
+ gdb_test "gu (print (value-lazy? argc-lazy))" "= #f"
+
+ # Test string fetches, both partial and whole.
+ gdb_test "print st" "\"divide et impera\""
+ gdb_scm_test_silent_cmd "gu (define st (history-ref 0))" \
+ "inf: get st value from history"
+ gdb_test "gu (print (value->string st))" \
+ "= divide et impera" "Test string with no length"
+ gdb_test "gu (print (value->string st #:length -1))" \
+ "= divide et impera" "Test string (length = -1) is all of the string"
+ gdb_test "gu (print (value->string st #:length 6))" \
+ "= divide"
+ gdb_test "gu (print (string-append \"---\" (value->string st #:length 0) \"---\"))" \
+ "= ------" "Test string (length = 0) is empty"
+ gdb_test "gu (print (string-length (value->string st #:length 0)))" \
+ "= 0" "Test length is 0"
+
+ # Fetch a string that has embedded nulls.
+ gdb_test "print nullst" "\"divide\\\\000et\\\\000impera\".*"
+ gdb_scm_test_silent_cmd "gu (define nullst (history-ref 0))" \
+ "inf: get nullst value from history"
+ gdb_test "gu (print (value->string nullst))" \
+ "divide" "Test string to first null"
+ gdb_scm_test_silent_cmd "gu (set! nullst (value->string nullst #:length 9))" \
+ "get string beyond null"
+ gdb_test "gu (print nullst)" \
+ "= divide\\\\000et"
+}
+
+proc test_strings {} {
+ gdb_test "gu (make-value \"test\")" "#<gdb:value \"test\">" "make string"
+
+ # Test string conversion errors.
+ set save_charset [get_target_charset]
+ gdb_test_no_output "set target-charset UTF-8"
+
+ gdb_test_no_output "gu (set-port-conversion-strategy! #f 'error)"
+ gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\"))" \
+ "ERROR.*decoding-error.*" \
+ "value->string with default #:errors = 'error"
+
+ # There is no 'escape strategy for C->SCM string conversions, but it's
+ # still a legitimate value for %default-port-conversion-strategy.
+ # GDB handles this by, umm, substituting 'substitute.
+ # Use this case to also handle "#:errors #f" which explicitly says
+ # "use %default-port-conversion-strategy".
+ gdb_test_no_output "gu (set-port-conversion-strategy! #f 'escape)"
+ gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\" #:errors #f))" \
+ "= \[?\]{3}" "value->string with default #:errors = 'escape"
+
+ # This is last in the default conversion tests so that
+ # %default-port-conversion-strategy ends up with the default value.
+ gdb_test_no_output "gu (set-port-conversion-strategy! #f 'substitute)"
+ gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\"))" \
+ "= \[?\]{3}" "value->string with default #:errors = 'substitute"
+
+ gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\" #:errors 'error))" \
+ "ERROR.*decoding-error.*" "value->string #:errors 'error"
+ gdb_test "gu (print (value->string (make-value (string #\\x1234)) #:encoding \"ASCII\" #:errors 'substitute))" \
+ "= \[?\]{3}" "value->string #:errors 'substitute"
+ gdb_test "gu (print (value->string (make-value \"abc\") #:errors \"foo\"))" \
+ "ERROR.*invalid error kind.*" "bad value for #:errors"
+
+ gdb_test_no_output "set target-charset $save_charset" \
+ "restore target-charset"
+}
+
+proc test_lazy_strings {} {
+ global hex
+
+ gdb_test "print sptr" "\"pointer\""
+ gdb_scm_test_silent_cmd "gu (define sptr (history-ref 0))" \
+ "lazy strings: get sptr value from history"
+
+ gdb_scm_test_silent_cmd "gu (define lstr (value->lazy-string sptr))" \
+ "Aquire lazy string"
+ gdb_test "gu (print (lazy-string-type lstr))" \
+ "= const char \*." "Test lazy-string type name equality"
+ gdb_test "gu (print (value-type sptr))" \
+ "= const char \*." "Test string type name equality"
+ gdb_test "print sn" "0x0"
+ gdb_scm_test_silent_cmd "gu (define snptr (history-ref 0))" \
+ "lazy strings: get snptr value from history"
+ gdb_test "gu (define snstr (value->lazy-string snptr #:length 5))" \
+ ".*cannot create a lazy string with address.*" "Test lazy string"
+ gdb_scm_test_silent_cmd "gu (define snstr (value->lazy-string snptr #:length 0))" \
+ "Successfully create a lazy string"
+ gdb_test "gu (print (lazy-string-length snstr))" \
+ "= 0" "Test lazy string length"
+ gdb_test "gu (print (lazy-string-address snstr))" \
+ "= 0" "Test lazy string address"
+}
+
+proc test_inferior_function_call {} {
+ global gdb_prompt hex decimal
+
+ # Correct inferior call without arguments.
+ gdb_test "p/x fp1" "= $hex.*"
+ gdb_scm_test_silent_cmd "gu (define fp1 (history-ref 0))" \
+ "get fp1 value from history"
+ gdb_scm_test_silent_cmd "gu (set! fp1 (value-dereference fp1))" \
+ "dereference fp1"
+ gdb_test "gu (print (value-call fp1 '()))" \
+ "= void"
+
+ # Correct inferior call with arguments.
+ gdb_test "p/x fp2" "= $hex.*"
+ gdb_scm_test_silent_cmd "gu (define fp2 (history-ref 0))" \
+ "get fp2 value from history"
+ gdb_scm_test_silent_cmd "gu (set! fp2 (value-dereference fp2))" \
+ "dereference fp2"
+ gdb_test "gu (print (value-call fp2 (list 10 20)))" \
+ "= 30"
+
+ # Incorrect to call an int value.
+ gdb_test "p i" "= $decimal.*"
+ gdb_scm_test_silent_cmd "gu (define i (history-ref 0))" \
+ "inf call: get i value from history"
+ gdb_test "gu (print (value-call i '()))" \
+ "ERROR: .*: Wrong type argument in position 1 \\(expecting function \\(value of TYPE_CODE_FUNC\\)\\): .*"
+
+ # Incorrect number of arguments.
+ gdb_test "p/x fp2" "= $hex.*"
+ gdb_scm_test_silent_cmd "gu (define fp3 (history-ref 0))" \
+ "get fp3 value from history"
+ gdb_scm_test_silent_cmd "gu (set! fp3 (value-dereference fp3))" \
+ "dereference fp3"
+ gdb_test "gu (print (value-call fp3 (list 10)))" \
+ "ERROR: Too few arguments in function call.*"
+}
+
+proc test_value_after_death {} {
+ # Construct a type while the inferior is still running.
+ gdb_scm_test_silent_cmd "gu (define ptrtype (lookup-type \"PTR\"))" \
+ "create PTR type"
+
+ # Kill the inferior and remove the symbols.
+ gdb_test "kill" "" "kill the inferior" \
+ "Kill the program being debugged. .y or n. $" \
+ "y"
+ gdb_test "file" "" "Discard the symbols" \
+ "Discard symbol table from.*y or n. $" \
+ "y"
+
+ # Now create a value using that type. Relies on arg0, created by
+ # test_value_in_inferior.
+ gdb_scm_test_silent_cmd "gu (define castval (value-cast arg0 (type-pointer ptrtype)))" \
+ "cast arg0 to PTR"
+
+ # Make sure the type is deleted.
+ gdb_scm_test_silent_cmd "gu (set! ptrtype #f)" \
+ "delete PTR type"
+
+ # Now see if the value's type is still valid.
+ gdb_test "gu (print (value-type castval))" \
+ "= PTR ." "print value's type"
+}
+
+# Regression test for invalid subscript operations. The bug was that
+# the type of the value was not being checked before allowing a
+# subscript operation to proceed.
+
+proc test_subscript_regression {exefile lang} {
+ # Start with a fresh gdb.
+ clean_restart ${exefile}
+
+ if ![gdb_guile_runto_main ] {
+ fail "Can't run to main"
+ return
+ }
+
+ if {$lang == "c++"} {
+ gdb_breakpoint [gdb_get_line_number "break to inspect pointer by reference"]
+ gdb_continue_to_breakpoint "break to inspect pointer by reference"
+
+ gdb_scm_test_silent_cmd "print rptr_int" \
+ "Obtain address"
+ gdb_scm_test_silent_cmd "gu (define rptr (history-ref 0))" \
+ "set rptr"
+ gdb_test "gu (print (value-subscript rptr 0))" \
+ "= 2" "Check pointer passed as reference"
+
+ # Just the most basic test of dynamic_cast -- it is checked in
+ # the C++ tests.
+ gdb_test "gu (print (value->bool (value-dynamic-cast (parse-and-eval \"base\") (type-pointer (lookup-type \"Derived\")))))" \
+ "= #t"
+
+ # Likewise.
+ gdb_test "gu (print (value-dynamic-type (parse-and-eval \"base\")))" \
+ "= Derived \[*\]"
+ # A static type case.
+ gdb_test "gu (print (value-dynamic-type (parse-and-eval \"5\")))" \
+ "= int"
+ }
+
+ gdb_breakpoint [gdb_get_line_number "break to inspect struct and union"]
+ gdb_continue_to_breakpoint "break to inspect struct and union"
+
+ gdb_scm_test_silent_cmd "gu (define intv (make-value 1))" \
+ "Create int value for subscript test"
+ gdb_scm_test_silent_cmd "gu (define stringv (make-value \"foo\"))" \
+ "Create string value for subscript test"
+
+ # Try to access an int with a subscript. This should fail.
+ gdb_test "gu (print intv)" \
+ "= 1" "Baseline print of an int Guile value"
+ gdb_test "gu (print (value-subscript intv 0))" \
+ "ERROR: Cannot subscript requested type.*" \
+ "Attempt to access an integer with a subscript"
+
+ # Try to access a string with a subscript. This should pass.
+ gdb_test "gu (print stringv)" \
+ "= \"foo\"" "Baseline print of a string Guile value"
+ gdb_test "gu (print (value-subscript stringv 0))" \
+ "= 102 'f'" "Attempt to access a string with a subscript"
+
+ # Try to access an int array via a pointer with a subscript.
+ # This should pass.
+ gdb_scm_test_silent_cmd "print p" "Build pointer to array"
+ gdb_scm_test_silent_cmd "gu (define pointer (history-ref 0))" "set pointer"
+ gdb_test "gu (print (value-subscript pointer 0))" \
+ "= 1" "Access array via pointer with int subscript"
+ gdb_test "gu (print (value-subscript pointer intv))" \
+ "= 2" "Access array via pointer with value subscript"
+
+ # Try to access a single dimension array with a subscript to the
+ # result. This should fail.
+ gdb_test "gu (print (value-subscript (value-subscript pointer intv) 0))" \
+ "ERROR: Cannot subscript requested type.*" \
+ "Attempt to access an integer with a subscript 2"
+
+ # Lastly, test subscript access to an array with multiple
+ # dimensions. This should pass.
+ gdb_scm_test_silent_cmd "print {\"fu \",\"foo\",\"bar\"}" "Build array"
+ gdb_scm_test_silent_cmd "gu (define marray (history-ref 0))" ""
+ gdb_test "gu (print (value-subscript (value-subscript marray 1) 2))" \
+ "o." "Test multiple subscript"
+}
+
+# A few tests of gdb:parse-and-eval.
+
+proc test_parse_and_eval {} {
+ gdb_test "gu (print (parse-and-eval \"23\"))" \
+ "= 23" "parse-and-eval constant test"
+ gdb_test "gu (print (parse-and-eval \"5 + 7\"))" \
+ "= 12" "parse-and-eval simple expression test"
+ gdb_test "gu (raw-print (parse-and-eval \"5 + 7\"))" \
+ "#<gdb:value 12>" "parse-and-eval type test"
+}
+
+# Test that values are hashable.
+# N.B.: While smobs are hashable, the hash is really non-existent,
+# they all get hashed to the same value. Guile may provide a hash function
+# for smobs in a future release. In the meantime one should use a custom
+# hash table that uses gdb:hash-gsmob.
+
+proc test_value_hash {} {
+ gdb_test_multiline "Simple Guile value dictionary" \
+ "guile" "" \
+ "(define one (make-value 1))" "" \
+ "(define two (make-value 2))" "" \
+ "(define three (make-value 3))" "" \
+ "(define vdict (make-hash-table 5))" "" \
+ "(hash-set! vdict one \"one str\")" "" \
+ "(hash-set! vdict two \"two str\")" "" \
+ "(hash-set! vdict three \"three str\")" "" \
+ "end"
+ gdb_test "gu (print (hash-ref vdict one))" \
+ "one str" "Test dictionary hash 1"
+ gdb_test "gu (print (hash-ref vdict two))" \
+ "two str" "Test dictionary hash 2"
+ gdb_test "gu (print (hash-ref vdict three))" \
+ "three str" "Test dictionary hash 3"
+}
+
+# Build C version of executable. C++ is built later.
+if { [build_inferior "${binfile}" "c"] < 0 } {
+ return
+}
+
+# Start with a fresh gdb.
+clean_restart ${binfile}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+gdb_install_guile_utils
+gdb_install_guile_module
+
+test_parse_and_eval
+test_value_hash
+
+# The following tests require execution.
+
+if ![gdb_guile_runto_main] {
+ fail "Can't run to main"
+ return
+}
+
+test_value_in_inferior
+test_inferior_function_call
+test_strings
+test_lazy_strings
+test_value_after_death
+
+# Test either C or C++ values.
+
+test_subscript_regression "${binfile}" "c"
+
+if ![skip_cplus_tests] {
+ if { [build_inferior "${binfile}-cxx" "c++"] < 0 } {
+ return
+ }
+ with_test_prefix "c++" {
+ test_subscript_regression "${binfile}-cxx" "c++"
+ }
+}
--- /dev/null
+;; This testcase is part of GDB, the GNU debugger.
+;;
+;; Copyright 2008-2014 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)
--- /dev/null
+/* This testcase is part of GDB, the GNU debugger.
+
+ Copyright 2014 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/>. */
+
+enum enum_type { A, B, C };
+
+class base
+{
+ public:
+ int base_member;
+};
+
+class derived : public base
+{
+ public:
+ enum_type derived_member;
+};
+
+derived d;
+
+int
+main (void)
+{
+ return 0;
+}
--- /dev/null
+# Copyright (C) 2014 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 (gdb types) module.
+
+load_lib gdb-guile.exp
+
+standard_testfile .cc
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile}] } {
+ return -1
+}
+
+# Skip all tests if Guile scripting is not enabled.
+if { [skip_guile_tests] } { continue }
+
+if ![gdb_guile_runto_main] {
+ return
+}
+
+gdb_scm_test_silent_cmd "guile (use-modules (gdb types))" \
+ "import (gdb types)"
+
+gdb_scm_test_silent_cmd "guile (define d (lookup-type \"derived\"))" \
+ "get derived type"
+
+gdb_test "guile (print (type-has-field? d \"base_member\"))" \
+ "= #f" "type-has-field? member in baseclass"
+
+gdb_test "guile (print (type-has-field-deep? d \"base_member\"))" \
+ "= #t" "type-has-field-deep? member in baseclass"
+
+gdb_scm_test_silent_cmd "guile (define enum-htab (make-enum-hashtable (lookup-type \"enum_type\")))" \
+ "create enum hash table"
+
+gdb_test "guile (print (hash-ref enum-htab \"B\"))" \
+ "= 1" "verify make-enum-hashtable"
--- /dev/null
+# Copyright 2010-2014 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/>.
+
+# Utilities for Guile-scripting related tests.
+
+# Guile doesn't print the 0x prefix on hex numbers.
+set ghex {[0-9a-f]+}
+
+# Return a 1 for configurations that do not support Guile scripting.
+
+proc skip_guile_tests {} {
+ global gdb_prompt
+
+ gdb_test_multiple "guile (display \"test\\n\")" "verify guile support" {
+ -re "Undefined command.*$gdb_prompt $" {
+ unsupported "Guile not supported."
+ return 1
+ }
+ -re "not supported.*$gdb_prompt $" {
+ unsupported "Guile support is disabled."
+ return 1
+ }
+ -re "$gdb_prompt $" {}
+ }
+
+ return 0
+}
+
+# Run a command in GDB, and report a failure if a Scheme exception is thrown.
+# If report_pass is true, report a pass if no exception is thrown.
+# This also catches the "Undefined command" error that happens if the user
+# passes, e.g., "(print foo)" instead of "guile (print foo)".
+
+proc gdb_scm_test_silent_cmd { cmd name {report_pass 1} } {
+ global gdb_prompt
+
+ gdb_test_multiple $cmd $name {
+ -re "Backtrace.*$gdb_prompt $" { fail $name }
+ -re "ERROR.*$gdb_prompt $" { fail $name }
+ -re "Undefined command: .*$gdb_prompt $" { fail $name }
+ -re "$gdb_prompt $" { if $report_pass { pass $name } }
+ }
+}
+
+# Usage: gdb_test_multiline NAME INPUT RESULT {INPUT RESULT} ...
+# Run a test named NAME, consisting of multiple lines of input.
+# After each input line INPUT, search for result line RESULT.
+# Succeed if all results are seen; fail otherwise.
+# FIXME: Move to gdb.exp and remove Python's gdb_py_test_multiple.
+
+proc gdb_test_multiline { name args } {
+ global gdb_prompt
+ foreach {input result} $args {
+ if {[gdb_test_multiple $input "$name - $input" {
+ -re "\[\r\n\]*($result)\[\r\n\]+($gdb_prompt | *>)$" {
+ pass "$name - $input"
+ }
+ }]} {
+ return 1
+ }
+ }
+ return 0
+}
+
+# Load Scheme file FILE_NAME.
+# TEST_NAME can be used to specify the name of the test,
+# otherwise a standard test name is provided.
+#
+# Note: When Guile loads something and auto-compilation is enabled
+# (which is useful and the default), then the first time a file is loaded
+# Guile will compile the file and store the result somewhere
+# (e.g., $HOME/.cache/guile). Output of the compilation process will
+# appear in gdb.log. But since Guile only does this when necessary
+# don't be confused if you don't always see it - Guile just skipped it
+# because it thought it was unnecessary.
+
+proc gdb_scm_load_file { file_name {test_name ""} } {
+ if { $test_name == "" } {
+ set test_name "guile (load \"[file tail $file_name]\")"
+ }
+ # Note: This can produce output if Guile compiles the file.
+ gdb_scm_test_silent_cmd "guile (load \"$file_name\")" $test_name
+}
+
+# Install various utilities in Guile to simplify tests.
+#
+# print - combination of display + newline
+
+proc gdb_install_guile_utils { } {
+ # Define utilities in Guile to save needing (newline) all the time,
+ # and in the case of "print" add a prefix to help erroneous passes.
+ gdb_test_no_output "guile (define (print x) (format #t \"= ~A\" x) (newline))"
+ gdb_test_no_output "guile (define (raw-print x) (format #t \"= ~S\" x) (newline))"
+}
+
+# Install the gdb module.
+
+proc gdb_install_guile_module { } {
+ gdb_test_no_output "guile (use-modules (gdb))"
+}
+
+# Wrapper around runto_main that installs the guile utils and module.
+# The result is the same as for runto_main.
+
+proc gdb_guile_runto_main { } {
+ if ![runto_main] {
+ fail "Can't run to main"
+ return 0
+ }
+
+ gdb_install_guile_utils
+ gdb_install_guile_module
+
+ return 1
+}
return [get_integer_valueof "sizeof (${type})" $default]
}
+proc get_target_charset { } {
+ global gdb_prompt
+
+ gdb_test_multiple "show target-charset" "" {
+ -re "The target character set is \"auto; currently (\[^\"\]*)\".*$gdb_prompt $" {
+ return $expect_out(1,string)
+ }
+ -re "The target character set is \"(\[^\"\]*)\".*$gdb_prompt $" {
+ return $expect_out(1,string)
+ }
+ }
+
+ # Pick a reasonable default.
+ warning "Unable to read target-charset."
+ return "UTF-8"
+}
+
# Get the current value for remotetimeout and return it.
proc get_remotetimeout { } {
global gdb_prompt
projects / binutils-gdb.git / commitdiff