diff options
114 files changed, 27862 insertions, 28 deletions
diff --git a/gdb/ChangeLog b/gdb/ChangeLog index 1e54611..99eb2fb 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -1,3 +1,99 @@ +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). diff --git a/gdb/Makefile.in b/gdb/Makefile.in index e714550..6c8db6f 100644 --- a/gdb/Makefile.in +++ b/gdb/Makefile.in @@ -280,6 +280,58 @@ SUBDIR_TUI_LDFLAGS= 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 # @@ -460,7 +512,7 @@ CFLAGS = @CFLAGS@ # 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 @@ -493,7 +545,8 @@ INTERNAL_LDFLAGS = $(CFLAGS) $(GLOBAL_CFLAGS) $(MH_LDFLAGS) $(LDFLAGS) $(CONFIG_ # 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) \ @@ -1126,6 +1179,9 @@ install-strip: `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 @@ -2177,7 +2233,99 @@ tui-winsource.o: $(srcdir)/tui/tui-winsource.c $(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 @@ -3,8 +3,39 @@ *** 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 diff --git a/gdb/auto-load.c b/gdb/auto-load.c index a2f6fb92..86d4e5e 100644 --- a/gdb/auto-load.c +++ b/gdb/auto-load.c @@ -39,7 +39,7 @@ #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). @@ -877,18 +877,22 @@ source_section_scripts (struct objfile *objfile, const char *section_name, 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; @@ -1395,6 +1399,8 @@ _initialize_auto_load (void) { 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, @@ -1439,16 +1445,26 @@ Usage: info auto-load local-gdbinit"), 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 (_("\ @@ -1456,7 +1472,7 @@ Automatically loaded scripts are located in one of the directories listed\n\ 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\ @@ -1464,7 +1480,8 @@ Directories listed here need to be present also \ 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, _("\ @@ -1477,6 +1494,7 @@ Show the list of directories from which to load auto-loaded scripts."), 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 (); diff --git a/gdb/breakpoint.h b/gdb/breakpoint.h index 8a5c4e8..4be9f23 100644 --- a/gdb/breakpoint.h +++ b/gdb/breakpoint.h @@ -29,6 +29,7 @@ struct value; struct block; struct gdbpy_breakpoint_object; +struct gdbscm_breakpoint_object; struct get_number_or_range_state; struct thread_info; struct bpstats; @@ -739,6 +740,9 @@ struct breakpoint 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 diff --git a/gdb/cli/cli-cmds.c b/gdb/cli/cli-cmds.c index 9374c1d..bfcd975 100644 --- a/gdb/cli/cli-cmds.c +++ b/gdb/cli/cli-cmds.c @@ -1225,7 +1225,7 @@ show_user (char *args, int from_tty) 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); @@ -1831,7 +1831,7 @@ you must type \"disassemble 'foo.c'::bar\" and not \"disassemble foo.c:bar\".")) 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, @@ -1839,8 +1839,8 @@ With no argument, show definitions of all user defined commands."), &showlist); 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); diff --git a/gdb/cli/cli-script.c b/gdb/cli/cli-script.c index 47cad75..246fcc9 100644 --- a/gdb/cli/cli-script.c +++ b/gdb/cli/cli-script.c @@ -91,6 +91,7 @@ multi_line_command_p (enum command_control_type type) case while_stepping_control: case commands_control: case python_control: + case guile_control: return 1; default: return 0; @@ -274,6 +275,19 @@ print_command_lines (struct ui_out *uiout, struct command_line *cmd, 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) */ @@ -589,6 +603,7 @@ execute_control_command (struct command_line *cmd) } case python_control: + case guile_control: { eval_ext_lang_from_control_command (cmd); ret = simple_control; @@ -1028,6 +1043,11 @@ process_next_line (char *p, struct command_line **command, int parse_commands, 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 *) @@ -1115,7 +1135,8 @@ recurse_read_control_structure (char * (*read_next_line_func) (void), 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. */ diff --git a/gdb/config.in b/gdb/config.in index 802127f..5c465679 100644 --- a/gdb/config.in +++ b/gdb/config.in @@ -159,6 +159,9 @@ /* 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 diff --git a/gdb/configure b/gdb/configure index 8ae2e09..f856cc4 100755 --- a/gdb/configure +++ b/gdb/configure @@ -658,6 +658,9 @@ TARGET_SYSTEM_ROOT CONFIG_LDFLAGS RDYNAMIC ALLOCA +GUILE_LIBS +GUILE_CPPFLAGS +pkg_config_prog_path PYTHON_LIBS PYTHON_CPPFLAGS PYTHON_CFLAGS @@ -813,6 +816,7 @@ with_gnu_ld enable_rpath with_libexpat_prefix with_python +with_guile enable_libmcheck with_included_regex with_sysroot @@ -1530,6 +1534,8 @@ Optional Packages: --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 @@ -8681,6 +8687,414 @@ fi +# -------------------- # +# 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. # # --------------------- # diff --git a/gdb/configure.ac b/gdb/configure.ac index feb28f3..73decd0 100644 --- a/gdb/configure.ac +++ b/gdb/configure.ac @@ -1054,6 +1054,154 @@ AC_SUBST(PYTHON_CFLAGS) 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. # # --------------------- # diff --git a/gdb/data-directory/Makefile.in b/gdb/data-directory/Makefile.in index 29a48e4..3288e50 100644 --- a/gdb/data-directory/Makefile.in +++ b/gdb/data-directory/Makefile.in @@ -19,8 +19,9 @@ 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@ @@ -72,6 +73,17 @@ PYTHON_FILES = \ 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 = \ @@ -111,7 +123,7 @@ FLAGS_TO_PASS = \ "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. @@ -195,6 +207,43 @@ uninstall-python: 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) @@ -246,13 +295,15 @@ install: all @$(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 @@ -411,6 +411,7 @@ enum command_control_type if_control, commands_control, python_control, + guile_control, while_stepping_control, invalid_control }; diff --git a/gdb/disasm.c b/gdb/disasm.c index 064ae05..d94225b 100644 --- a/gdb/disasm.c +++ b/gdb/disasm.c @@ -376,7 +376,7 @@ fprintf_disasm (void *stream, const char *format, ...) return 0; } -static struct disassemble_info +struct disassemble_info gdb_disassemble_info (struct gdbarch *gdbarch, struct ui_file *file) { struct disassemble_info di; diff --git a/gdb/disasm.h b/gdb/disasm.h index d2d5f51..9c6777c 100644 --- a/gdb/disasm.h +++ b/gdb/disasm.h @@ -19,15 +19,23 @@ #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); diff --git a/gdb/doc/ChangeLog b/gdb/doc/ChangeLog index 7ccabc4..1dd7231 100644 --- a/gdb/doc/ChangeLog +++ b/gdb/doc/ChangeLog @@ -1,3 +1,14 @@ +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 diff --git a/gdb/doc/Makefile.in b/gdb/doc/Makefile.in index cf63e4a..a578d3a 100644 --- a/gdb/doc/Makefile.in +++ b/gdb/doc/Makefile.in @@ -130,6 +130,7 @@ GDB_DOC_BUILD_INCLUDES = \ GDBvn.texi GDB_DOC_FILES = \ $(srcdir)/gdb.texinfo \ + $(srcdir)/guile.texi \ $(GDB_DOC_SOURCE_INCLUDES) \ $(GDB_DOC_BUILD_INCLUDES) diff --git a/gdb/doc/gdb.texinfo b/gdb/doc/gdb.texinfo index af14286..035573e 100644 --- a/gdb/doc/gdb.texinfo +++ b/gdb/doc/gdb.texinfo @@ -22324,6 +22324,12 @@ These are @value{GDBN} control commands for the auto-loading: @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}. @@ -22950,7 +22956,9 @@ being debugged. @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 @@ -27953,6 +27961,9 @@ substitute_prompt (``frame: \f, @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 @@ -27998,6 +28009,8 @@ where @var{ext} is the file extension for the extension language: 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} @@ -28091,6 +28104,7 @@ for example, this GCC macro for Python scripts. @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 @@ -28162,6 +28176,26 @@ cumbersome. It may be easier to specify the scripts in the 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 diff --git a/gdb/doc/guile.texi b/gdb/doc/guile.texi new file mode 100644 index 0000000..efabea8 --- /dev/null +++ b/gdb/doc/guile.texi @@ -0,0 +1,3278 @@ +@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 diff --git a/gdb/extension.c b/gdb/extension.c index a61f5ca..c2f502b 100644 --- a/gdb/extension.c +++ b/gdb/extension.c @@ -30,6 +30,7 @@ #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. @@ -100,6 +101,7 @@ static const struct extension_language_defn * const extension_languages[] = { /* To preserve existing behaviour, python should always appear first. */ &extension_language_python, + &extension_language_guile, NULL }; diff --git a/gdb/extension.h b/gdb/extension.h index 8408701..61dc81b 100644 --- a/gdb/extension.h +++ b/gdb/extension.h @@ -53,7 +53,8 @@ enum extension_language { EXT_LANG_NONE, EXT_LANG_GDB, - EXT_LANG_PYTHON + EXT_LANG_PYTHON, + EXT_LANG_GUILE }; /* Extension language frame-filter status return values. */ diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c index 042c17d..622eff0 100644 --- a/gdb/gdbtypes.c +++ b/gdb/gdbtypes.c @@ -1446,6 +1446,40 @@ lookup_struct_elt_type (struct type *type, const char *name, int noerr) 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, diff --git a/gdb/gdbtypes.h b/gdb/gdbtypes.h index 61ddeff..643c610 100644 --- a/gdb/gdbtypes.h +++ b/gdb/gdbtypes.h @@ -1545,6 +1545,10 @@ extern struct type *lookup_unsigned_typename (const struct language_defn *, 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) \ diff --git a/gdb/guile/README b/gdb/guile/README new file mode 100644 index 0000000..81306e5 --- /dev/null +++ b/gdb/guile/README @@ -0,0 +1,229 @@ +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. + +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 ..." diff --git a/gdb/guile/guile-internal.h b/gdb/guile/guile-internal.h new file mode 100644 index 0000000..dcdd422 --- /dev/null +++ b/gdb/guile/guile-internal.h @@ -0,0 +1,567 @@ +/* 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; + +/* 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); + +/* 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); + +/* 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); + +/* 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); + +/* stript_lang methods */ + +extern objfile_script_sourcer_func gdbscm_source_objfile_script; + +extern int gdbscm_auto_load_enabled (const struct extension_language_defn *); + +extern void gdbscm_preserve_values + (const struct extension_language_defn *, + struct objfile *, htab_t copied_types); + +extern enum ext_lang_rc gdbscm_apply_val_pretty_printer + (const struct extension_language_defn *, + struct type *type, const gdb_byte *valaddr, + int embedded_offset, CORE_ADDR address, + struct ui_file *stream, int recurse, + const struct value *val, + const struct value_print_options *options, + const struct language_defn *language); + +extern int gdbscm_breakpoint_has_cond (const struct extension_language_defn *, + struct breakpoint *b); + +extern enum ext_lang_bp_stop gdbscm_breakpoint_cond_says_stop + (const struct extension_language_defn *, struct breakpoint *b); + +/* Initializers for each piece of Scheme support, in alphabetical order. */ + +extern void gdbscm_initialize_arches (void); +extern void gdbscm_initialize_auto_load (void); +extern void gdbscm_initialize_blocks (void); +extern void gdbscm_initialize_breakpoints (void); +extern void gdbscm_initialize_disasm (void); +extern void gdbscm_initialize_exceptions (void); +extern void gdbscm_initialize_frames (void); +extern void gdbscm_initialize_iterators (void); +extern void gdbscm_initialize_lazy_strings (void); +extern void gdbscm_initialize_math (void); +extern void gdbscm_initialize_objfiles (void); +extern void gdbscm_initialize_pretty_printers (void); +extern void gdbscm_initialize_ports (void); +extern void gdbscm_initialize_smobs (void); +extern void gdbscm_initialize_strings (void); +extern void gdbscm_initialize_symbols (void); +extern void gdbscm_initialize_symtabs (void); +extern void gdbscm_initialize_types (void); +extern void gdbscm_initialize_values (void); + +/* Use these after a TRY_CATCH to throw the appropriate Scheme exception + if a GDB error occurred. */ + +#define GDBSCM_HANDLE_GDB_EXCEPTION(exception) \ + do { \ + if (exception.reason < 0) \ + { \ + gdbscm_throw_gdb_exception (exception); \ + /*NOTREACHED */ \ + } \ + } while (0) + +/* If cleanups are establish outside the TRY_CATCH block, use this version. */ + +#define GDBSCM_HANDLE_GDB_EXCEPTION_WITH_CLEANUPS(exception, cleanups) \ + do { \ + if (exception.reason < 0) \ + { \ + do_cleanups (cleanups); \ + gdbscm_throw_gdb_exception (exception); \ + /*NOTREACHED */ \ + } \ + } while (0) + +#endif /* GDB_GUILE_INTERNAL_H */ diff --git a/gdb/guile/guile.c b/gdb/guile/guile.c new file mode 100644 index 0000000..b7134f7 --- /dev/null +++ b/gdb/guile/guile.c @@ -0,0 +1,724 @@ +/* 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 +}; + +#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); + } +} + +/* (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 */ + +/* Lists for 'set,show,info guile' commands. */ + +static struct cmd_list_element *set_guile_list; +static struct cmd_list_element *show_guile_list; +static struct cmd_list_element *info_guile_list; + +/* Function for use by 'set guile' prefix command. */ + +static void +set_guile_command (char *args, int from_tty) +{ + help_list (set_guile_list, "set guile ", all_commands, gdb_stdout); +} + +/* Function for use by 'show guile' prefix command. */ + +static void +show_guile_command (char *args, int from_tty) +{ + cmd_show_list (show_guile_list, from_tty, ""); +} + +/* The "info scheme" command is defined as a prefix, with + allow_unknown 0. Therefore, its own definition is called only for + "info scheme" with no args. */ + +static void +info_guile_command (char *args, int from_tty) +{ + printf_unfiltered (_("\"info guile\" must be followed" + " by the name of an info command.\n")); + help_list (info_guile_list, "info guile ", -1, gdb_stdout); +} + +/* Initialization. */ + +#ifdef HAVE_GUILE + +static const scheme_function misc_guile_functions[] = +{ + { "execute", 1, 0, 1, gdbscm_execute_gdb_command, + "\ +Execute the given GDB command.\n\ +\n\ + Arguments: string [#:to-string boolean] [#:from-tty boolean]\n\ + If #:from-tty is true then the command executes as if entered\n\ + from the keyboard. The default is false (#f).\n\ + If #:to-string is true then the result is returned as a string.\n\ + Otherwise output is sent to the current output port,\n\ + which is the default.\n\ + Returns: The result of the command if #:to-string is true.\n\ + Otherwise returns unspecified." }, + + { "data-directory", 0, 0, 0, gdbscm_data_directory, + "\ +Return the name of GDB's data directory." }, + + { "gdb-version", 0, 0, 0, gdbscm_gdb_version, + "\ +Return GDB's version string." }, + + { "host-config", 0, 0, 0, gdbscm_host_config, + "\ +Return the name of the host configuration." }, + + { "target-config", 0, 0, 0, gdbscm_target_config, + "\ +Return the name of the target configuration." }, + + END_FUNCTIONS +}; + +/* Load gdb/boot.scm, the Scheme side of GDB/Guile support. + Note: This function assumes it's called within the gdb module. */ + +static void +initialize_scheme_side (void) +{ + char *gdb_guile_dir = concat (gdb_datadir, SLASH_STRING, "guile", NULL); + char *boot_scm_path = concat (gdb_guile_dir, SLASH_STRING, "gdb", + SLASH_STRING, boot_scm_filename, NULL); + char *msg; + + /* While scm_c_primitive_load works, the loaded code is not compiled, + instead it is left to be interpreted. Eh? + Anyways, this causes a ~100x slowdown, so we only use it to load + gdb/boot.scm, and then let boot.scm do the rest. */ + msg = gdbscm_safe_source_script (boot_scm_path); + + if (msg != NULL) + { + fprintf_filtered (gdb_stderr, "%s", msg); + xfree (msg); + warning (_("\n" + "Could not complete Guile gdb module initialization from:\n" + "%s.\n" + "Limited Guile support is available.\n" + "Suggest passing --data-directory=/path/to/gdb/data-directory.\n"), + boot_scm_path); + } + + xfree (gdb_guile_dir); + xfree (boot_scm_path); +} + +/* Install the gdb scheme module. + The result is a boolean indicating success. + If initializing the gdb module fails an error message is printed. + Note: This function runs in the context of the gdb module. */ + +static void +initialize_gdb_module (void *data) +{ + /* The documentation symbol needs to be defined before any calls to + gdbscm_define_{variables,functions}. */ + gdbscm_documentation_symbol = 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 +} diff --git a/gdb/guile/guile.h b/gdb/guile/guile.h new file mode 100644 index 0000000..333047d --- /dev/null +++ b/gdb/guile/guile.h @@ -0,0 +1,28 @@ +/* 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 */ diff --git a/gdb/guile/lib/gdb.scm b/gdb/guile/lib/gdb.scm new file mode 100644 index 0000000..f12769e --- /dev/null +++ b/gdb/guile/lib/gdb.scm @@ -0,0 +1,452 @@ +;; 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 +) diff --git a/gdb/guile/lib/gdb/boot.scm b/gdb/guile/lib/gdb/boot.scm new file mode 100644 index 0000000..cf7d305 --- /dev/null +++ b/gdb/guile/lib/gdb/boot.scm @@ -0,0 +1,31 @@ +;; 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)) diff --git a/gdb/guile/lib/gdb/experimental.scm b/gdb/guile/lib/gdb/experimental.scm new file mode 100644 index 0000000..ffded84 --- /dev/null +++ b/gdb/guile/lib/gdb/experimental.scm @@ -0,0 +1,35 @@ +;; 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)))) diff --git a/gdb/guile/lib/gdb/init.scm b/gdb/guile/lib/gdb/init.scm new file mode 100644 index 0000000..12ad67d --- /dev/null +++ b/gdb/guile/lib/gdb/init.scm @@ -0,0 +1,173 @@ +;; 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)))) + +;; 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) diff --git a/gdb/guile/lib/gdb/iterator.scm b/gdb/guile/lib/gdb/iterator.scm new file mode 100644 index 0000000..9cfbe85 --- /dev/null +++ b/gdb/guile/lib/gdb/iterator.scm @@ -0,0 +1,80 @@ +;; 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)))))) diff --git a/gdb/guile/lib/gdb/printing.scm b/gdb/guile/lib/gdb/printing.scm new file mode 100644 index 0000000..36e3275 --- /dev/null +++ b/gdb/guile/lib/gdb/printing.scm @@ -0,0 +1,52 @@ +;; 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!)))) diff --git a/gdb/guile/lib/gdb/types.scm b/gdb/guile/lib/gdb/types.scm new file mode 100644 index 0000000..31ea192 --- /dev/null +++ b/gdb/guile/lib/gdb/types.scm @@ -0,0 +1,78 @@ +;; 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)) diff --git a/gdb/guile/scm-arch.c b/gdb/guile/scm-arch.c new file mode 100644 index 0000000..fa578f3 --- /dev/null +++ b/gdb/guile/scm-arch.c @@ -0,0 +1,668 @@ +/* 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); + +/* 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; +} + +/* 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)); +} + +/* 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); +} + +/* 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); +} diff --git a/gdb/guile/scm-auto-load.c b/gdb/guile/scm-auto-load.c new file mode 100644 index 0000000..5b9eb23 --- /dev/null +++ b/gdb/guile/scm-auto-load.c @@ -0,0 +1,81 @@ +/* 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); +} + +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 ()); +} diff --git a/gdb/guile/scm-block.c b/gdb/guile/scm-block.c new file mode 100644 index 0000000..de41af2 --- /dev/null +++ b/gdb/guile/scm-block.c @@ -0,0 +1,828 @@ +/* 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; + +/* 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); + } +} + +/* 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); +} + +/* 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); +} + +/* (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; +} + +/* 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); +} diff --git a/gdb/guile/scm-breakpoint.c b/gdb/guile/scm-breakpoint.c new file mode 100644 index 0000000..d022377 --- /dev/null +++ b/gdb/guile/scm-breakpoint.c @@ -0,0 +1,1200 @@ +/* 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; + +/* 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; +} + +/* 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); +} + +/* 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; +} + +/* 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); + } + } +} + +/* 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"); +} diff --git a/gdb/guile/scm-disasm.c b/gdb/guile/scm-disasm.c new file mode 100644 index 0000000..dc76b98 --- /dev/null +++ b/gdb/guile/scm-disasm.c @@ -0,0 +1,355 @@ +/* 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; +}; + +/* 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); +} + +/* 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"); +} diff --git a/gdb/guile/scm-exception.c b/gdb/guile/scm-exception.c new file mode 100644 index 0000000..a96a350 --- /dev/null +++ b/gdb/guile/scm-exception.c @@ -0,0 +1,691 @@ +/* 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; + +/* 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; +} + +/* 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); +} + +/* 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"); +} diff --git a/gdb/guile/scm-frame.c b/gdb/guile/scm-frame.c new file mode 100644 index 0000000..a46d1e3 --- /dev/null +++ b/gdb/guile/scm-frame.c @@ -0,0 +1,1077 @@ +/* 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; + +/* 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); + } +} + +/* 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); +} + +/* 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); +} diff --git a/gdb/guile/scm-gsmob.c b/gdb/guile/scm-gsmob.c new file mode 100644 index 0000000..5f9e856 --- /dev/null +++ b/gdb/guile/scm-gsmob.c @@ -0,0 +1,486 @@ +/* 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; +} + +/* 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; +} + +/* 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); +} + +/* 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); +} diff --git a/gdb/guile/scm-iterator.c b/gdb/guile/scm-iterator.c new file mode 100644 index 0000000..a6deb84 --- /dev/null +++ b/gdb/guile/scm-iterator.c @@ -0,0 +1,375 @@ +/* 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; +} + +/* 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); +} + +/* 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); +} + +/* 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"); +} diff --git a/gdb/guile/scm-lazy-string.c b/gdb/guile/scm-lazy-string.c new file mode 100644 index 0000000..e965d01 --- /dev/null +++ b/gdb/guile/scm-lazy-string.c @@ -0,0 +1,373 @@ +/* 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; + +/* 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; +} + +/* 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); +} + +/* 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); +} diff --git a/gdb/guile/scm-math.c b/gdb/guile/scm-math.c new file mode 100644 index 0000000..80e1673 --- /dev/null +++ b/gdb/guile/scm-math.c @@ -0,0 +1,998 @@ +/* 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); +} + +/* 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); +} + +/* 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); +} diff --git a/gdb/guile/scm-objfile.c b/gdb/guile/scm-objfile.c new file mode 100644 index 0000000..9a20dc7 --- /dev/null +++ b/gdb/guile/scm-objfile.c @@ -0,0 +1,413 @@ +/* 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; +} + +/* 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; +} + +/* 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; +} + +/* 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); +} + +/* 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); +} diff --git a/gdb/guile/scm-ports.c b/gdb/guile/scm-ports.c new file mode 100644 index 0000000..30bbc97 --- /dev/null +++ b/gdb/guile/scm-ports.c @@ -0,0 +1,1372 @@ +/* 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; + +/* 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; +} + +/* 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)); +} + +/* 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; +} + +/* 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; +} + +/* 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); +} + +/* 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; +} + +/* 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); +} diff --git a/gdb/guile/scm-pretty-print.c b/gdb/guile/scm-pretty-print.c new file mode 100644 index 0000000..1b9902f4 --- /dev/null +++ b/gdb/guile/scm-pretty-print.c @@ -0,0 +1,1138 @@ +/* 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; + +/* 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; +} + +/* 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; +} + +/* 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)); +} + +/* 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; +} + +/* 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"); +} diff --git a/gdb/guile/scm-safe-call.c b/gdb/guile/scm-safe-call.c new file mode 100644 index 0000000..147d7f5 --- /dev/null +++ b/gdb/guile/scm-safe-call.c @@ -0,0 +1,464 @@ +/* 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; +} + +/* 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); +} + +/* 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); +} + +/* 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; +} + +/* 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; +} + +/* 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); +} diff --git a/gdb/guile/scm-string.c b/gdb/guile/scm-string.c new file mode 100644 index 0000000..87ecabf --- /dev/null +++ b/gdb/guile/scm-string.c @@ -0,0 +1,246 @@ +/* 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); +} + +/* 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); +} diff --git a/gdb/guile/scm-symbol.c b/gdb/guile/scm-symbol.c new file mode 100644 index 0000000..53cc272 --- /dev/null +++ b/gdb/guile/scm-symbol.c @@ -0,0 +1,777 @@ +/* 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; + +/* 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); + } +} + +/* 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); +} + +/* (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); +} + +/* 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); +} diff --git a/gdb/guile/scm-symtab.c b/gdb/guile/scm-symtab.c new file mode 100644 index 0000000..910d8b7 --- /dev/null +++ b/gdb/guile/scm-symtab.c @@ -0,0 +1,735 @@ +/* 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; + +/* 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); + } +} + +/* 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); +} + +/* 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; +} + +/* 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); +} + +/* 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); +} diff --git a/gdb/guile/scm-type.c b/gdb/guile/scm-type.c new file mode 100644 index 0000000..36cba79 --- /dev/null +++ b/gdb/guile/scm-type.c @@ -0,0 +1,1495 @@ +/* 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; +} + +/* 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); +} + +/* 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); +} + +/* 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); +} + +/* 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 (); +} + +/* 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; +} + +/* 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; +} + +/* 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); +} diff --git a/gdb/guile/scm-utils.c b/gdb/guile/scm-utils.c new file mode 100644 index 0000000..9e9901d --- /dev/null +++ b/gdb/guile/scm-utils.c @@ -0,0 +1,585 @@ +/* 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); + } +} + +/* 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); +} + +/* 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); +} + +/* 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)); +} diff --git a/gdb/guile/scm-value.c b/gdb/guile/scm-value.c new file mode 100644 index 0000000..f7f27cee --- /dev/null +++ b/gdb/guile/scm-value.c @@ -0,0 +1,1485 @@ +/* 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; + +/* 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; +} + +/* 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; +} + +/* (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); +} + +/* 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"); +} diff --git a/gdb/testsuite/ChangeLog b/gdb/testsuite/ChangeLog index 8b9ec44..da1348b 100644 --- a/gdb/testsuite/ChangeLog +++ b/gdb/testsuite/ChangeLog @@ -1,3 +1,64 @@ +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 diff --git a/gdb/testsuite/configure b/gdb/testsuite/configure index aa08add..4bf6121 100755 --- a/gdb/testsuite/configure +++ b/gdb/testsuite/configure @@ -3448,7 +3448,7 @@ done -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 @@ -4170,6 +4170,7 @@ do "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" ;; diff --git a/gdb/testsuite/configure.ac b/gdb/testsuite/configure.ac index b6640bd..fb084d4 100644 --- a/gdb/testsuite/configure.ac +++ b/gdb/testsuite/configure.ac @@ -95,7 +95,7 @@ AC_OUTPUT([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 \ diff --git a/gdb/testsuite/gdb.base/help.exp b/gdb/testsuite/gdb.base/help.exp index c55eaf6..c4032a5 100644 --- a/gdb/testsuite/gdb.base/help.exp +++ b/gdb/testsuite/gdb.base/help.exp @@ -124,4 +124,4 @@ gdb_test "apropos \\\(print\[\^ bsiedf\\\".-\]\\\)" "handle -- Specify how to ha # 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.*" diff --git a/gdb/testsuite/gdb.guile/Makefile.in b/gdb/testsuite/gdb.guile/Makefile.in new file mode 100644 index 0000000..37f9cb0 --- /dev/null +++ b/gdb/testsuite/gdb.guile/Makefile.in @@ -0,0 +1,17 @@ +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 diff --git a/gdb/testsuite/gdb.guile/guile.exp b/gdb/testsuite/gdb.guile/guile.exp new file mode 100644 index 0000000..2a171fe --- /dev/null +++ b/gdb/testsuite/gdb.guile/guile.exp @@ -0,0 +1,77 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-arch.c b/gdb/testsuite/gdb.guile/scm-arch.c new file mode 100644 index 0000000..6c0ef92 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-arch.c @@ -0,0 +1,22 @@ +/* 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; +} diff --git a/gdb/testsuite/gdb.guile/scm-arch.exp b/gdb/testsuite/gdb.guile/scm-arch.exp new file mode 100644 index 0000000..1fcf615 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-arch.exp @@ -0,0 +1,33 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-block.c b/gdb/testsuite/gdb.guile/scm-block.c new file mode 100644 index 0000000..69c37d0 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-block.c @@ -0,0 +1,38 @@ +/* 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. */ +} diff --git a/gdb/testsuite/gdb.guile/scm-block.exp b/gdb/testsuite/gdb.guile/scm-block.exp new file mode 100644 index 0000000..32d109a --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-block.exp @@ -0,0 +1,107 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-breakpoint.c b/gdb/testsuite/gdb.guile/scm-breakpoint.c new file mode 100644 index 0000000..c8dc7f7 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-breakpoint.c @@ -0,0 +1,44 @@ +/* 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. */ +} diff --git a/gdb/testsuite/gdb.guile/scm-breakpoint.exp b/gdb/testsuite/gdb.guile/scm-breakpoint.exp new file mode 100644 index 0000000..b25d4e0 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-breakpoint.exp @@ -0,0 +1,438 @@ +# 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 diff --git a/gdb/testsuite/gdb.guile/scm-disasm.c b/gdb/testsuite/gdb.guile/scm-disasm.c new file mode 100644 index 0000000..6c0ef92 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-disasm.c @@ -0,0 +1,22 @@ +/* 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; +} diff --git a/gdb/testsuite/gdb.guile/scm-disasm.exp b/gdb/testsuite/gdb.guile/scm-disasm.exp new file mode 100644 index 0000000..5a1dae3 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-disasm.exp @@ -0,0 +1,133 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-equal.c b/gdb/testsuite/gdb.guile/scm-equal.c new file mode 100644 index 0000000..108c9be --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-equal.c @@ -0,0 +1,24 @@ +/* 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; +} diff --git a/gdb/testsuite/gdb.guile/scm-equal.exp b/gdb/testsuite/gdb.guile/scm-equal.exp new file mode 100644 index 0000000..ae23aa8 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-equal.exp @@ -0,0 +1,55 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-error-1.scm b/gdb/testsuite/gdb.guile/scm-error-1.scm new file mode 100644 index 0000000..a68f491 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-error-1.scm @@ -0,0 +1,19 @@ +;; 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)) diff --git a/gdb/testsuite/gdb.guile/scm-error-2.scm b/gdb/testsuite/gdb.guile/scm-error-2.scm new file mode 100644 index 0000000..87a7ee5 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-error-2.scm @@ -0,0 +1,30 @@ +;; 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)) diff --git a/gdb/testsuite/gdb.guile/scm-error.exp b/gdb/testsuite/gdb.guile/scm-error.exp new file mode 100644 index 0000000..b5a1028 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-error.exp @@ -0,0 +1,117 @@ +# 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.*" diff --git a/gdb/testsuite/gdb.guile/scm-frame-args.c b/gdb/testsuite/gdb.guile/scm-frame-args.c new file mode 100644 index 0000000..c20b1e1 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-frame-args.c @@ -0,0 +1,60 @@ +/* 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; +} diff --git a/gdb/testsuite/gdb.guile/scm-frame-args.exp b/gdb/testsuite/gdb.guile/scm-frame-args.exp new file mode 100644 index 0000000..22ce6fe --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-frame-args.exp @@ -0,0 +1,76 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-frame-args.scm b/gdb/testsuite/gdb.guile/scm-frame-args.scm new file mode 100644 index 0000000..20d42f8 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-frame-args.scm @@ -0,0 +1,69 @@ +;; 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*) diff --git a/gdb/testsuite/gdb.guile/scm-frame-inline.c b/gdb/testsuite/gdb.guile/scm-frame-inline.c new file mode 100644 index 0000000..a3669bc --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-frame-inline.c @@ -0,0 +1,43 @@ +/* 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 (); +} diff --git a/gdb/testsuite/gdb.guile/scm-frame-inline.exp b/gdb/testsuite/gdb.guile/scm-frame-inline.exp new file mode 100644 index 0000000..ed1c3b8 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-frame-inline.exp @@ -0,0 +1,43 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-frame.c b/gdb/testsuite/gdb.guile/scm-frame.c new file mode 100644 index 0000000..82db341 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-frame.c @@ -0,0 +1,30 @@ +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); +} diff --git a/gdb/testsuite/gdb.guile/scm-frame.exp b/gdb/testsuite/gdb.guile/scm-frame.exp new file mode 100644 index 0000000..04c8cda --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-frame.exp @@ -0,0 +1,122 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-generics.exp b/gdb/testsuite/gdb.guile/scm-generics.exp new file mode 100644 index 0000000..664affc --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-generics.exp @@ -0,0 +1,42 @@ +# 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>" diff --git a/gdb/testsuite/gdb.guile/scm-gsmob.exp b/gdb/testsuite/gdb.guile/scm-gsmob.exp new file mode 100644 index 0000000..470afc4 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-gsmob.exp @@ -0,0 +1,70 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-iterator.c b/gdb/testsuite/gdb.guile/scm-iterator.c new file mode 100644 index 0000000..80e9178 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-iterator.c @@ -0,0 +1,28 @@ +/* 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. */ +} diff --git a/gdb/testsuite/gdb.guile/scm-iterator.exp b/gdb/testsuite/gdb.guile/scm-iterator.exp new file mode 100644 index 0000000..8ee67ed --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-iterator.exp @@ -0,0 +1,62 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-math.c b/gdb/testsuite/gdb.guile/scm-math.c new file mode 100644 index 0000000..347fc22 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-math.c @@ -0,0 +1,30 @@ +/* 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; +} diff --git a/gdb/testsuite/gdb.guile/scm-math.exp b/gdb/testsuite/gdb.guile/scm-math.exp new file mode 100644 index 0000000..12caa71 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-math.exp @@ -0,0 +1,309 @@ +# 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 diff --git a/gdb/testsuite/gdb.guile/scm-objfile-script-gdb.in b/gdb/testsuite/gdb.guile/scm-objfile-script-gdb.in new file mode 100644 index 0000000..e576721 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-objfile-script-gdb.in @@ -0,0 +1,55 @@ +;; 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*) diff --git a/gdb/testsuite/gdb.guile/scm-objfile-script.c b/gdb/testsuite/gdb.guile/scm-objfile-script.c new file mode 100644 index 0000000..10f4776 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-objfile-script.c @@ -0,0 +1,39 @@ +/* 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 */ +} diff --git a/gdb/testsuite/gdb.guile/scm-objfile-script.exp b/gdb/testsuite/gdb.guile/scm-objfile-script.exp new file mode 100644 index 0000000..65d0c44 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-objfile-script.exp @@ -0,0 +1,57 @@ +# 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>" diff --git a/gdb/testsuite/gdb.guile/scm-objfile.c b/gdb/testsuite/gdb.guile/scm-objfile.c new file mode 100644 index 0000000..dbdc9b3 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-objfile.c @@ -0,0 +1,23 @@ +/* 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; +} diff --git a/gdb/testsuite/gdb.guile/scm-objfile.exp b/gdb/testsuite/gdb.guile/scm-objfile.exp new file mode 100644 index 0000000..70da488 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-objfile.exp @@ -0,0 +1,57 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-ports.exp b/gdb/testsuite/gdb.guile/scm-ports.exp new file mode 100644 index 0000000..ceb9a5f --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-ports.exp @@ -0,0 +1,37 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-pretty-print.c b/gdb/testsuite/gdb.guile/scm-pretty-print.c new file mode 100644 index 0000000..0fd05f5 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-pretty-print.c @@ -0,0 +1,353 @@ +/* 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; +} diff --git a/gdb/testsuite/gdb.guile/scm-pretty-print.exp b/gdb/testsuite/gdb.guile/scm-pretty-print.exp new file mode 100644 index 0000000..cd3ae95 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-pretty-print.exp @@ -0,0 +1,148 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-pretty-print.scm b/gdb/testsuite/gdb.guile/scm-pretty-print.scm new file mode 100644 index 0000000..a42527c --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-pretty-print.scm @@ -0,0 +1,301 @@ +;; 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*) diff --git a/gdb/testsuite/gdb.guile/scm-section-script.c b/gdb/testsuite/gdb.guile/scm-section-script.c new file mode 100644 index 0000000..8a1ede9 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-section-script.c @@ -0,0 +1,55 @@ +/* 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 */ +} diff --git a/gdb/testsuite/gdb.guile/scm-section-script.exp b/gdb/testsuite/gdb.guile/scm-section-script.exp new file mode 100644 index 0000000..0c5e489 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-section-script.exp @@ -0,0 +1,80 @@ +# 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>" diff --git a/gdb/testsuite/gdb.guile/scm-section-script.scm b/gdb/testsuite/gdb.guile/scm-section-script.scm new file mode 100644 index 0000000..cd31db9 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-section-script.scm @@ -0,0 +1,55 @@ +;; 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*) diff --git a/gdb/testsuite/gdb.guile/scm-symbol.c b/gdb/testsuite/gdb.guile/scm-symbol.c new file mode 100644 index 0000000..3201365 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-symbol.c @@ -0,0 +1,69 @@ +/* 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. */ +} diff --git a/gdb/testsuite/gdb.guile/scm-symbol.exp b/gdb/testsuite/gdb.guile/scm-symbol.exp new file mode 100644 index 0000000..5d25c53 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-symbol.exp @@ -0,0 +1,196 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-symtab-2.c b/gdb/testsuite/gdb.guile/scm-symtab-2.c new file mode 100644 index 0000000..d45aa6c --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-symtab-2.c @@ -0,0 +1,28 @@ +/* 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; +} diff --git a/gdb/testsuite/gdb.guile/scm-symtab.c b/gdb/testsuite/gdb.guile/scm-symtab.c new file mode 100644 index 0000000..e4662cd --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-symtab.c @@ -0,0 +1,45 @@ +/* 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. */ +} diff --git a/gdb/testsuite/gdb.guile/scm-symtab.exp b/gdb/testsuite/gdb.guile/scm-symtab.exp new file mode 100644 index 0000000..4309ae6 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-symtab.exp @@ -0,0 +1,142 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-type.c b/gdb/testsuite/gdb.guile/scm-type.c new file mode 100644 index 0000000..7cee383 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-type.c @@ -0,0 +1,77 @@ +/* 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. */ +} diff --git a/gdb/testsuite/gdb.guile/scm-type.exp b/gdb/testsuite/gdb.guile/scm-type.exp new file mode 100644 index 0000000..4a3969e --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-type.exp @@ -0,0 +1,299 @@ +# 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 +} diff --git a/gdb/testsuite/gdb.guile/scm-value-cc.cc b/gdb/testsuite/gdb.guile/scm-value-cc.cc new file mode 100644 index 0000000..df19f0b --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-value-cc.cc @@ -0,0 +1,39 @@ +/* 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); +} diff --git a/gdb/testsuite/gdb.guile/scm-value-cc.exp b/gdb/testsuite/gdb.guile/scm-value-cc.exp new file mode 100644 index 0000000..685deb1 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-value-cc.exp @@ -0,0 +1,57 @@ +# 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" diff --git a/gdb/testsuite/gdb.guile/scm-value.c b/gdb/testsuite/gdb.guile/scm-value.c new file mode 100644 index 0000000..3c61911 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-value.c @@ -0,0 +1,101 @@ +/* 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; +} diff --git a/gdb/testsuite/gdb.guile/scm-value.exp b/gdb/testsuite/gdb.guile/scm-value.exp new file mode 100644 index 0000000..3ebdd58 --- /dev/null +++ b/gdb/testsuite/gdb.guile/scm-value.exp @@ -0,0 +1,449 @@ +# 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++" + } +} diff --git a/gdb/testsuite/gdb.guile/source2.scm b/gdb/testsuite/gdb.guile/source2.scm new file mode 100644 index 0000000..f00c269 --- /dev/null +++ b/gdb/testsuite/gdb.guile/source2.scm @@ -0,0 +1,19 @@ +;; 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) diff --git a/gdb/testsuite/gdb.guile/types-module.cc b/gdb/testsuite/gdb.guile/types-module.cc new file mode 100644 index 0000000..90c682a --- /dev/null +++ b/gdb/testsuite/gdb.guile/types-module.cc @@ -0,0 +1,38 @@ +/* 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; +} diff --git a/gdb/testsuite/gdb.guile/types-module.exp b/gdb/testsuite/gdb.guile/types-module.exp new file mode 100644 index 0000000..8562f3c --- /dev/null +++ b/gdb/testsuite/gdb.guile/types-module.exp @@ -0,0 +1,50 @@ +# 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" diff --git a/gdb/testsuite/lib/gdb-guile.exp b/gdb/testsuite/lib/gdb-guile.exp new file mode 100644 index 0000000..d46f200 --- /dev/null +++ b/gdb/testsuite/lib/gdb-guile.exp @@ -0,0 +1,127 @@ +# 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 +} diff --git a/gdb/testsuite/lib/gdb.exp b/gdb/testsuite/lib/gdb.exp index 3716472..66dc8f7 100644 --- a/gdb/testsuite/lib/gdb.exp +++ b/gdb/testsuite/lib/gdb.exp @@ -4399,6 +4399,23 @@ proc get_sizeof { type default } { 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 |