Index: Makefile.in =================================================================== RCS file: /cvs/src/src/gdb/Makefile.in,v retrieving revision 1.1267 diff -u -p -r1.1267 Makefile.in --- Makefile.in 22 Aug 2013 23:46:28 -0000 1.1267 +++ Makefile.in 6 Sep 2013 15:17:12 -0000 @@ -272,6 +272,34 @@ SUBDIR_TUI_LDFLAGS= SUBDIR_TUI_CFLAGS= \ -DTUI=1 +# scheme sub directory definitons for guile support + +SUBDIR_SCHEME_OBS = \ + scheme.o \ + scm-breakpoint.o \ + scm-exception.o \ + scm-iterator.o \ + scm-pretty-print.o \ + scm-smobs.o \ + scm-type.o \ + scm-type-printers.o \ + scm-utils.o \ + scm-value.o +SUBDIR_SCHEME_SRCS = \ + scheme/scheme.c \ + scheme/scm-breakpoint.c \ + scheme/scm-exception.c \ + scheme/scm-iterator.c \ + scheme/scm-pretty-print.c \ + scheme/scm-smobs.c \ + scheme/scm-type.c \ + scheme/scm-type-printers.c \ + scheme/scm-utils.c \ + scheme/scm-value.c +SUBDIR_SCHEME_DEPS = +SUBDIR_SCHEME_LDFLAGS= +SUBDIR_SCHEME_CFLAGS= + # # python sub directory definitons # @@ -450,7 +478,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@ @SCHEME_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 @@ -483,7 +511,8 @@ INTERNAL_LDFLAGS = $(CFLAGS) $(GLOBAL_CF # 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@ @SCHEME_LIBS@ @PYTHON_LIBS@ \ $(LIBEXPAT) $(LIBLZMA) $(LIBBABELTRACE) \ $(LIBIBERTY) $(WIN32LIBS) $(LIBGNU) CDEPS = $(XM_CDEPS) $(NAT_CDEPS) $(SIM) $(BFD) $(READLINE_DEPS) \ @@ -752,7 +781,7 @@ SFILES = ada-exp.y ada-lang.c ada-typepr proc-service.list progspace.c \ prologue-value.c psymtab.c \ regcache.c reggroups.c remote.c remote-fileio.c remote-notif.c reverse.c \ - sentinel-frame.c \ + scripting.c sentinel-frame.c \ serial.c ser-base.c ser-unix.c skip.c \ solib.c solib-target.c source.c \ stabsread.c stack.c probe.c stap-probe.c std-regs.c \ @@ -912,6 +941,7 @@ COMMON_OBS = $(DEPFILES) $(CONFIG_OBS) $ osabi.o copying.o \ memattr.o mem-break.o target.o parse.o language.o buildsym.o \ findcmd.o \ + scripting.o \ std-regs.o \ signals.o \ exec.o reverse.o \ @@ -1073,6 +1103,9 @@ install-only: $(CONFIG_INSTALL) fi @$(MAKE) DO=install "DODIRS=$(SUBDIRS)" $(FLAGS_TO_PASS) subdir_do +install-scheme: + $(SHELL) $(srcdir)/../mkinstalldirs $(DESTDIR)$(GDB_DATADIR)/scheme/gdb + install-python: $(SHELL) $(srcdir)/../mkinstalldirs $(DESTDIR)$(GDB_DATADIR)/python/gdb @@ -2120,7 +2153,52 @@ tui-winsource.o: $(srcdir)/tui/tui-winso $(COMPILE) $(srcdir)/tui/tui-winsource.c $(POSTCOMPILE) +# Guile support. +# gdb/scheme dependencies # +# Need to explicitly specify the compile rule as make will do nothing +# or try to compile the object file into the sub-directory. + +scheme.o: $(srcdir)/scheme/scheme.c + $(COMPILE) $(srcdir)/scheme/scheme.c + $(POSTCOMPILE) + +scm-breakpoint.o: $(srcdir)/scheme/scm-breakpoint.c + $(COMPILE) $(srcdir)/scheme/scm-breakpoint.c + $(POSTCOMPILE) + +scm-exception.o: $(srcdir)/scheme/scm-exception.c + $(COMPILE) $(srcdir)/scheme/scm-exception.c + $(POSTCOMPILE) + +scm-iterator.o: $(srcdir)/scheme/scm-iterator.c + $(COMPILE) $(srcdir)/scheme/scm-iterator.c + $(POSTCOMPILE) + +scm-pretty-print.o: $(srcdir)/scheme/scm-pretty-print.c + $(COMPILE) $(srcdir)/scheme/scm-pretty-print.c + $(POSTCOMPILE) + +scm-smobs.o: $(srcdir)/scheme/scm-smobs.c + $(COMPILE) $(srcdir)/scheme/scm-smobs.c + $(POSTCOMPILE) + +scm-type.o: $(srcdir)/scheme/scm-type.c + $(COMPILE) $(srcdir)/scheme/scm-type.c + $(POSTCOMPILE) + +scm-type-printers.o: $(srcdir)/scheme/scm-type-printers.c + $(COMPILE) $(srcdir)/scheme/scm-type-printers.c + $(POSTCOMPILE) + +scm-utils.o: $(srcdir)/scheme/scm-utils.c + $(COMPILE) $(srcdir)/scheme/scm-utils.c + $(POSTCOMPILE) + +scm-value.o: $(srcdir)/scheme/scm-value.c + $(COMPILE) $(srcdir)/scheme/scm-value.c + $(POSTCOMPILE) + # gdb/python/ dependencies # # Need to explicitly specify the compile rule as make will do nothing Index: auto-load.c =================================================================== RCS file: /cvs/src/src/gdb/auto-load.c,v retrieving revision 1.21 diff -u -p -r1.21 auto-load.c --- auto-load.c 22 Apr 2013 16:46:14 -0000 1.21 +++ auto-load.c 6 Sep 2013 15:17:12 -0000 @@ -846,7 +846,7 @@ load_auto_scripts_for_objfile (struct ob if (auto_load_gdb_scripts) auto_load_objfile_script (objfile, &script_language_gdb); - gdbpy_load_auto_scripts_for_objfile (objfile); + load_slang_auto_scripts_for_objfile (objfile); } /* This is a new_objfile observer callback to auto-load scripts. @@ -1234,6 +1234,7 @@ Usage: info auto-load local-gdbinit"), auto_load_info_cmdlist_get ()); auto_load_dir = xstrdup (AUTO_LOAD_DIR); + // TODO: xyzdje scripts_directory_help = xstrprintf ( #ifdef HAVE_PYTHON _("\ Index: breakpoint.c =================================================================== RCS file: /cvs/src/src/gdb/breakpoint.c,v retrieving revision 1.776 diff -u -p -r1.776 breakpoint.c --- breakpoint.c 23 Aug 2013 06:22:09 -0000 1.776 +++ breakpoint.c 6 Sep 2013 15:17:12 -0000 @@ -1048,14 +1048,6 @@ condition_command (char *arg, int from_t ALL_BREAKPOINTS (b) if (b->number == bnum) { - /* Check if this breakpoint has a Python object assigned to - it, and if it has a definition of the "stop" - method. This method and conditions entered into GDB from - the CLI are mutually exclusive. */ - if (b->py_bp_object - && gdbpy_breakpoint_has_py_cond (b->py_bp_object)) - error (_("Cannot set a condition where a Python 'stop' " - "method has been defined in the breakpoint.")); set_breakpoint_condition (b, p, from_tty); if (is_breakpoint (b)) @@ -4609,7 +4601,7 @@ bpstat_print (bpstat bs, int kind) return PRINT_UNKNOWN; } -/* Evaluate the expression EXP and return 1 if value is zero. This is +/* Evaluate the expression EXP and return 1 if value is nonzero. This is used inside a catch_errors to evaluate the breakpoint condition. The argument is a "struct expression *" that has been cast to a "char *" to make it pass through catch_errors. */ @@ -4618,7 +4610,7 @@ static int breakpoint_cond_eval (void *exp) { struct value *mark = value_mark (); - int i = !value_true (evaluate_expression ((struct expression *) exp)); + int i = value_true (evaluate_expression ((struct expression *) exp)); value_free_to_mark (mark); return i; @@ -5059,7 +5051,6 @@ bpstat_check_watchpoint (bpstat bs) } } - /* Check conditions (condition proper, frame, thread and ignore count) of breakpoint referred to by BS. If we should not stop for this breakpoint, set BS->stop to 0. */ @@ -5070,6 +5061,12 @@ bpstat_check_breakpoint_conditions (bpst int thread_id = pid_to_thread_id (ptid); const struct bp_location *bl; struct breakpoint *b; + struct expression *cli_cond; + int cli_cond_is_nonzero = 0; + int have_slang_cond; + int slang_cond_is_nonzero = 0; + + gdb_assert (bs->stop); /* BS is built for existing struct breakpoint. */ bl = bs->bp_location_at; @@ -5083,111 +5080,127 @@ bpstat_check_breakpoint_conditions (bpst if (frame_id_p (b->frame_id) && !frame_id_eq (b->frame_id, get_stack_frame_id (get_current_frame ()))) - bs->stop = 0; - else if (bs->stop) { - int value_is_zero = 0; - struct expression *cond; + bs->stop = 0; + return; + } - /* Evaluate Python breakpoints that have a "stop" - method implemented. */ - if (b->py_bp_object) - bs->stop = gdbpy_should_stop (b->py_bp_object); + /* Don't evaluate the condition if this is a thread-specific breakpoint for + a different thread. */ - if (is_watchpoint (b)) - { - struct watchpoint *w = (struct watchpoint *) b; + if (b->thread != -1 && b->thread != thread_id) + { + bs->stop = 0; + return; + } - cond = w->cond_exp; - } - else - cond = bl->cond; + /* Similarly, don't evaluate the condition if we're still ignoring this + breakpoint. */ - if (cond && b->disposition != disp_del_at_next_stop) - { - int within_current_scope = 1; - struct watchpoint * w; + if (b->ignore_count > 0) + { + b->ignore_count--; + bs->stop = 0; + /* Increase the hit count even though we don't stop. */ + ++(b->hit_count); + observer_notify_breakpoint_modified (b); + return; + } - /* We use value_mark and value_free_to_mark because it could - be a long time before we return to the command level and - call free_all_values. We can't call free_all_values - because we might be in the middle of evaluating a - function call. */ - struct value *mark = value_mark (); + /* The default is to stop when the breakpoint is reached. + However, if the breakpoint has a condition (either from the CLI, + or from a scripting language), then only stop if at least one of + the conditions is TRUE. */ - if (is_watchpoint (b)) - w = (struct watchpoint *) b; - else - w = NULL; + /* Evaluate Python/Scheme breakpoints that have a "stop" + method implemented. */ + have_slang_cond = breakpoint_has_slang_cond (b); + if (have_slang_cond) + slang_cond_is_nonzero = breakpoint_slang_cond_says_stop (b); - /* Need to select the frame, with all that implies so that - the conditions will have the right context. Because we - use the frame, we will not see an inlined function's - variables when we arrive at a breakpoint at the start - of the inlined function; the current frame will be the - call site. */ - if (w == NULL || w->cond_exp_valid_block == NULL) - select_frame (get_current_frame ()); - else - { - struct frame_info *frame; + if (is_watchpoint (b)) + { + struct watchpoint *w = (struct watchpoint *) b; - /* For local watchpoint expressions, which particular - instance of a local is being watched matters, so we - keep track of the frame to evaluate the expression - in. To evaluate the condition however, it doesn't - really matter which instantiation of the function - where the condition makes sense triggers the - watchpoint. This allows an expression like "watch - global if q > 10" set in `func', catch writes to - global on all threads that call `func', or catch - writes on all recursive calls of `func' by a single - thread. We simply always evaluate the condition in - the innermost frame that's executing where it makes - sense to evaluate the condition. It seems - intuitive. */ - frame = block_innermost_frame (w->cond_exp_valid_block); - if (frame != NULL) - select_frame (frame); - else - within_current_scope = 0; - } - if (within_current_scope) - value_is_zero - = catch_errors (breakpoint_cond_eval, cond, - "Error in testing breakpoint condition:\n", - RETURN_MASK_ALL); - else - { - warning (_("Watchpoint condition cannot be tested " - "in the current scope")); - /* If we failed to set the right context for this - watchpoint, unconditionally report it. */ - value_is_zero = 0; - } - /* FIXME-someday, should give breakpoint #. */ - value_free_to_mark (mark); - } + cli_cond = w->cond_exp; + } + else + cli_cond = bl->cond; - if (cond && value_is_zero) - { - bs->stop = 0; + if (cli_cond && b->disposition != disp_del_at_next_stop) + { + int within_current_scope = 1; + struct watchpoint * w; + + /* We use value_mark and value_free_to_mark because it could + be a long time before we return to the command level and + call free_all_values. We can't call free_all_values + because we might be in the middle of evaluating a + function call. */ + struct value *mark = value_mark (); + + if (is_watchpoint (b)) + w = (struct watchpoint *) b; + else + w = NULL; + + /* Need to select the frame, with all that implies so that + the conditions will have the right context. Because we + use the frame, we will not see an inlined function's + variables when we arrive at a breakpoint at the start + of the inlined function; the current frame will be the + call site. */ + if (w == NULL || w->cond_exp_valid_block == NULL) + select_frame (get_current_frame ()); + else + { + struct frame_info *frame; + + /* For local watchpoint expressions, which particular + instance of a local is being watched matters, so we + keep track of the frame to evaluate the expression + in. To evaluate the condition however, it doesn't + really matter which instantiation of the function + where the condition makes sense triggers the + watchpoint. This allows an expression like "watch + global if q > 10" set in `func', catch writes to + global on all threads that call `func', or catch + writes on all recursive calls of `func' by a single + thread. We simply always evaluate the condition in + the innermost frame that's executing where it makes + sense to evaluate the condition. It seems + intuitive. */ + frame = block_innermost_frame (w->cond_exp_valid_block); + if (frame != NULL) + select_frame (frame); + else + within_current_scope = 0; } - else if (b->thread != -1 && b->thread != thread_id) + if (within_current_scope) + cli_cond_is_nonzero + = catch_errors (breakpoint_cond_eval, cli_cond, + "Error in testing breakpoint condition:\n", + RETURN_MASK_ALL); + else { - bs->stop = 0; + warning (_("Watchpoint condition cannot be tested " + "in the current scope")); + /* If we failed to set the right context for this + watchpoint, unconditionally report it. */ + cli_cond_is_nonzero = 1; } - else if (b->ignore_count > 0) - { - b->ignore_count--; - bs->stop = 0; - /* Increase the hit count even though we don't stop. */ - ++(b->hit_count); - observer_notify_breakpoint_modified (b); - } + /* FIXME-someday, should give breakpoint #. */ + value_free_to_mark (mark); } -} + if (cli_cond || have_slang_cond) + { + if (cli_cond_is_nonzero || slang_cond_is_nonzero) + ; /* Nothing to do, bs->stop already set. */ + else + bs->stop = 0; + } +} /* Get a bpstat associated with having just stopped at address BP_ADDR in thread PTID. Index: breakpoint.h =================================================================== RCS file: /cvs/src/src/gdb/breakpoint.h,v retrieving revision 1.202 diff -u -p -r1.202 breakpoint.h --- breakpoint.h 27 Jul 2013 07:11:46 -0000 1.202 +++ breakpoint.h 6 Sep 2013 15:17:12 -0000 @@ -28,7 +28,8 @@ struct value; struct block; -struct breakpoint_object; +struct gdbpy_breakpoint_object; +struct gdbscm_breakpoint_object; struct get_number_or_range_state; struct thread_info; struct bpstats; @@ -756,8 +757,11 @@ struct breakpoint Python object that has been associated with this breakpoint. This is always NULL for a GDB that is not script enabled. It can sometimes be NULL for enabled GDBs as not all breakpoint - types are tracked by the Python scripting API. */ - struct breakpoint_object *py_bp_object; + types are tracked by the scripting language API. */ + struct gdbpy_breakpoint_object *py_bp_object; + + /* Same as py_bp_object, but for Guile. */ + struct gdbscm_breakpoint_object *scm_bp_object; }; /* An instance of this type is used to represent a watchpoint. It Index: configure.ac =================================================================== RCS file: /cvs/src/src/gdb/configure.ac,v retrieving revision 1.213 diff -u -p -r1.213 configure.ac --- configure.ac 22 Aug 2013 23:46:28 -0000 1.213 +++ configure.ac 6 Sep 2013 15:17:12 -0000 @@ -712,6 +712,10 @@ else fi fi +# --------------------- # +# Check for libpython. # +# --------------------- # + dnl Utility to simplify finding libpython. dnl $1 = pythonX.Y dnl $2 = the shell variable to assign the result to @@ -1050,6 +1054,120 @@ AC_SUBST(PYTHON_CFLAGS) AC_SUBST(PYTHON_CPPFLAGS) AC_SUBST(PYTHON_LIBS) +# -------------------- # +# Check for libguile. # +# -------------------- # + +dnl Utility to simplify finding libguile. +dnl $1 = guile-config-program +dnl $2 = yes|no, indicating whether to flag errors or ignore them +dnl $3 = the shell variable to assign the result to +dnl If libguile is found we store "yes" here. + +dnl FIXME: Need to support pkg-config guile-2.0 --cflags|--libs + +AC_DEFUN([AC_TRY_LIBGUILE], +[ + guile_config=$1 + flag_errors=$2 + define([have_libguile_var],$3) + found_usable_guile=checking + AC_MSG_CHECKING([for usable guile from ${guile_config}]) + new_CPPFLAGS=`${guile_config} compile` + if test $? != 0; then + if test "${flag_errors}" = yes; then + AC_ERROR(failure running guile-config compile) + fi + found_usable_guile=no + fi + new_LIBS=`${guile_config} link` + if test $? != 0; then + if test "${flag_errors}" = yes; then + AC_ERROR(failure running guile-config link) + fi + found_usable_guile=no + fi + if test "${found_usable_guile}" = checking; 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 + found_usable_guile=yes + SCHEME_CPPFLAGS=$new_CPPFLAGS + SCHEME_LIBS=$new_LIBS], + [found_usable_guile=no]) + CPPFLAGS=$save_CPPFLAGS + LIBS=$save_LIBS + 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 guile-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 /path/to/guile-config - +dnl Use the guile-config program located in this directory. +dnl NOTE: This needn't be the "real" guile-config program. +dnl In a cross-compilation scenario (build != host), this could be +dnl a shell script that provides what guile-config provides for +dnl "compile" and "link". + +AC_ARG_WITH(guile, + AS_HELP_STRING([--with-guile@<:@=GUILE@:>@], [include guile support (auto/yes/no/)]), + [], [with_guile=auto]) +AC_MSG_CHECKING([whether to use guile]) +AC_MSG_RESULT([$with_guile]) + +have_libguile=no +case "${with_guile}" in +no) + AC_MSG_WARN([guile support disabled; some features may be unavailable.]) + ;; +auto) + AC_TRY_LIBGUILE(guile-config, no, have_libguile) + ;; +yes) + AC_TRY_LIBGUILE(guile-config, yes, have_libguile) + ;; +[[\\/]]* | ?:[[\\/]]*) + AC_TRY_LIBGUILE(${with_guile}, yes, have_libguile) + ;; +*/*) + # Disallow --with-guile=foo/bar. + AC_ERROR(invalid value for --with-guile) + ;; +*) + AC_ERROR(invalid value for --with-guile) + ;; +esac + +if test "${have_libguile}" != no; then + AC_DEFINE(HAVE_SCHEME, 1, [Define if Guile interpreter is being linked in.]) + CONFIG_OBS="$CONFIG_OBS \$(SUBDIR_SCHEME_OBS)" + CONFIG_DEPS="$CONFIG_DEPS \$(SUBDIR_SCHEME_DEPS)" + CONFIG_SRCS="$CONFIG_SRCS \$(SUBDIR_SCHEME_SRCS)" + CONFIG_INSTALL="$CONFIG_INSTALL install-scheme" + ENABLE_CFLAGS="$ENABLE_CFLAGS \$(SUBDIR_SCHEME_CFLAGS)" +else + # Even if Guile support is not compiled in, we need to have these files + # included. + CONFIG_OBS="$CONFIG_OBS scheme.o" + CONFIG_SRCS="$CONFIG_SRCS scheme/scheme.c" +fi +AC_SUBST(SCHEME_CPPFLAGS) +AC_SUBST(SCHEME_LIBS) + +# --------------------- # +# Check for libmcheck. # +# --------------------- # + # Enable -lmcheck by default (it provides cheap-enough memory mangling), # but turn it off if Python is enabled with threads, since -lmcheck is # not thread safe (http://sourceware.org/bugzilla/show_bug.cgi?id=9939), Index: cp-valprint.c =================================================================== RCS file: /cvs/src/src/gdb/cp-valprint.c,v retrieving revision 1.91 diff -u -p -r1.91 cp-valprint.c --- cp-valprint.c 9 Jul 2013 16:57:09 -0000 1.91 +++ cp-valprint.c 6 Sep 2013 15:17:12 -0000 @@ -587,17 +587,16 @@ cp_print_value (struct type *type, struc { int result = 0; - /* Attempt to run the Python pretty-printers on the + /* Attempt to run the scripting language pretty-printers on the baseclass if possible. */ if (!options->raw) - result = apply_val_pretty_printer (baseclass, base_valaddr, - thisoffset + boffset, - value_address (base_val), - stream, recurse, base_val, - options, current_language); + result = apply_val_slang_pretty_printer (baseclass, base_valaddr, + thisoffset + boffset, + value_address (base_val), + stream, recurse, base_val, + options, + current_language); - - if (!result) cp_print_value_fields (baseclass, thistype, base_valaddr, thisoffset + boffset, Index: defs.h =================================================================== RCS file: /cvs/src/src/gdb/defs.h,v retrieving revision 1.332 diff -u -p -r1.332 defs.h --- defs.h 9 Jul 2013 16:57:09 -0000 1.332 +++ defs.h 6 Sep 2013 15:17:12 -0000 @@ -167,7 +167,9 @@ extern char *debug_file_directory; for Python and GDB SIGINT handling to coexist seamlessly. If GDB is built without Python, it instead uses its traditional - variables. */ + variables. + + TODO: Guile support. */ /* Clear the quit flag. */ extern void clear_quit_flag (void); @@ -417,6 +419,7 @@ enum command_control_type if_control, commands_control, python_control, + scheme_control, while_stepping_control, invalid_control }; Index: language.h =================================================================== RCS file: /cvs/src/src/gdb/language.h,v retrieving revision 1.89 diff -u -p -r1.89 language.h --- language.h 13 Mar 2013 18:34:53 -0000 1.89 +++ language.h 6 Sep 2013 15:17:12 -0000 @@ -24,10 +24,12 @@ #define LANGUAGE_H 1 /* Forward decls for prototypes. */ +struct block; struct value; struct objfile; struct frame_info; struct expression; +struct symbol; struct ui_file; struct value_print_options; struct type_print_options; Index: scripting.c =================================================================== RCS file: scripting.c diff -N scripting.c --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ scripting.c 6 Sep 2013 15:17:12 -0000 @@ -0,0 +1,422 @@ +/* Interface between gdb and its scripting languages. + + Copyright (C) 2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* Note: With few exceptions, external functions and variables in this file + have "slang" in the name, and no other symbol in gdb does. */ + +#include "defs.h" +#include "breakpoint.h" +#include "scripting.h" +#include "scheme/scheme.h" +#include "python/python.h" + +static const struct script_lang * const scripting_languages[] = +{ + /* Python appears first to avoid breaking existing code if there are + problems in the new Guile support. E.g. if there's a Python + pretty-printer then it has priority. */ +#ifdef HAVE_PYTHON + &python_scripting_interface, +#endif +#ifdef HAVE_SCHEME + &scheme_scripting_interface, +#endif + NULL +}; + +#define ALL_SCRIPTING_LANGUAGES(i, slang) \ + for (/*int*/ i = 0, slang = scripting_languages[0]; \ + slang != NULL; \ + slang = scripting_languages[++i]) + +void +finish_slang_initialization (void) +{ + int i; + const struct script_lang *slang; + + ALL_SCRIPTING_LANGUAGES (i, slang) + { + slang->finish_initialization (); + } +} + +#ifndef HAVE_PYTHON + +/* Throw UNSUPPORTED_ERROR if called. + This is used to implement script_ext_{soft,hard}. */ + +static void +source_python_unsupported (FILE *f, const char *file) +{ + throw_error (UNSUPPORTED_ERROR, + _("Python scripting is not supported in this copy of GDB.")); +} + +#endif + +#ifndef HAVE_SCHEME + +/* Throw UNSUPPORTED_ERROR if called. + This is used to implement script_ext_{soft,hard}. */ + +static void +source_scheme_unsupported (FILE *f, const char *file) +{ + throw_error (UNSUPPORTED_ERROR, + _("Scheme scripting is not supported in this copy of GDB.")); +} + +#endif + +/* Return TRUE if FILE has extension EXTENSION. */ + +static int +has_extension (const char *file, const char *extension) +{ + int file_len = strlen (file); + int extension_len = strlen (extension); + + return (file_len > extension_len + && strcmp (&file[file_len - extension_len], extension) == 0); +} + +/* Return a function to load FILE. + If FILE specifies a scripting language we support but which is not + enabled then return a function that throws UNSUPPORTED_ERROR. + Otherwise return NULL. + + Note: This could be a lot cleaner if not for script_ext_soft. */ + +slang_sourcer_func * +get_slang_sourcer (const char *file) +{ + if (has_extension (file, ".py")) + { +#ifdef HAVE_PYTHON + return python_scripting_interface.source_script; +#else + return source_python_unsupported; +#endif + } + + if (has_extension (file, ".scm")) + { +#ifdef HAVE_SCHEME + return scheme_scripting_interface.source_script; +#else + return source_scheme_unsupported; +#endif + } + + return NULL; +} + +static const char * +script_lang_name_from_control_command (struct command_line *cmd) +{ + switch (cmd->control_type) + { + case python_control: + return "Python"; + case scheme_control: + return "Scheme"; + default: + gdb_assert_not_reached ("invalid scripting language in cli command"); + } +} + +void +eval_slang_from_control_command (struct command_line *cmd) +{ + int i; + const struct script_lang *slang; + const char *script_lang_name; + + ALL_SCRIPTING_LANGUAGES (i, slang) + { + if (slang->cli_control_type == cmd->control_type) + { + slang->eval_from_control_command (cmd); + return; + } + } + + /* This requested scripting language is not supported. */ + + error (_("%s scripting is not supported in this copy of GDB."), + script_lang_name_from_control_command (cmd)); +} + +void +load_slang_auto_scripts_for_objfile (struct objfile *objfile) +{ + int i; + const struct script_lang *slang; + + ALL_SCRIPTING_LANGUAGES (i, slang) + { + slang->load_auto_scripts_for_objfile (objfile); + } +} + +struct slang_type_printers * +start_slang_type_printers (void) +{ + struct slang_type_printers *printers = XZALLOC (struct slang_type_printers); + int i; + const struct script_lang *slang; + + ALL_SCRIPTING_LANGUAGES (i, slang) + { + slang->start_type_printers (printers); + } + + return printers; +} + +char * +apply_slang_type_printers (struct slang_type_printers *printers, + struct type *type) +{ + int i; + const struct script_lang *slang; + + ALL_SCRIPTING_LANGUAGES (i, slang) + { + char *result = slang->apply_type_printers (printers, type); + + if (result != NULL) + return result; + } + + return NULL; +} + +void +free_slang_type_printers (struct slang_type_printers *printers) +{ + int i; + const struct script_lang *slang; + + ALL_SCRIPTING_LANGUAGES (i, slang) + { + slang->free_type_printers (printers); + } + + xfree (printers); +} + +int +apply_val_slang_pretty_printer (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) +{ + int i; + const struct script_lang *slang; + + ALL_SCRIPTING_LANGUAGES (i, slang) + { + if (slang->apply_val_pretty_printer == NULL) + continue; + if (slang->apply_val_pretty_printer (type, valaddr, embedded_offset, + address, stream, recurse, val, + options, language)) + return 1; + } + + return 0; +} + +enum py_bt_status +apply_slang_frame_filter (struct frame_info *frame, int flags, + enum py_frame_args args_type, struct ui_out *out, + int frame_low, int frame_high) +{ + int i; + const struct script_lang *slang; + + ALL_SCRIPTING_LANGUAGES (i, slang) + { + enum py_bt_status status; + + if (slang->apply_frame_filter == NULL) + continue; + status = slang->apply_frame_filter (frame, flags, args_type, out, + frame_low, frame_high); + if (status != PY_BT_NO_FILTERS) + return status; + } + + /* TODO: What to do if both Guile and Python filters are registered, + and applicable. */ + + return PY_BT_NO_FILTERS; +} + +void +preserve_slang_values (struct objfile *objfile, htab_t copied_types) +{ + int i; + const struct script_lang *slang; + + ALL_SCRIPTING_LANGUAGES (i, slang) + { + slang->preserve_values (objfile, copied_types); + } +} + +int +breakpoint_has_slang_cond (struct breakpoint *b) +{ + /* The code is organized so that the asserts are done first. */ + +#ifndef HAVE_PYTHON + gdb_assert (b->py_bp_object == NULL); +#endif + +#ifndef HAVE_SCHEME + gdb_assert (b->scm_bp_object == NULL); +#endif + +#ifdef HAVE_PYTHON + if (python_scripting_interface.breakpoint_has_cond (b)) + return 1; +#endif + +#ifdef HAVE_SCHEME + if (scheme_scripting_interface.breakpoint_has_cond != NULL + && scheme_scripting_interface.breakpoint_has_cond (b)) + return 1; +#endif + + return 0; +} + +int +breakpoint_slang_cond_says_stop (struct breakpoint *b) +{ + /* The code is organized so that the asserts are done first. */ + +#ifndef HAVE_PYTHON + gdb_assert (b->py_bp_object == NULL); +#endif + +#ifndef HAVE_SCHEME + gdb_assert (b->scm_bp_object == NULL); +#endif + +#ifdef HAVE_PYTHON + if (python_scripting_interface.breakpoint_cond_says_stop (b)) + return 1; +#endif + +#ifdef HAVE_SCHEME + if (scheme_scripting_interface.breakpoint_cond_says_stop != NULL + && scheme_scripting_interface.breakpoint_cond_says_stop (b)) + return 1; +#endif + + return 0; +} + +/* ^C/SIGINT support. + This requires cooperation with the scripting languages so the support + is defined here. + The prototypes for these are in defs.h. + + TODO: Guile support. */ + +#ifndef HAVE_PYTHON +/* Nonzero means a quit has been requested. */ +static int quit_flag; +#endif /* HAVE_PYTHON */ + +/* Clear the quit flag. */ + +void +clear_quit_flag (void) +{ +#ifdef HAVE_PYTHON + python_scripting_interface.clear_quit_flag (); +#else + quit_flag = 0; +#endif +} + +/* Set the quit flag. */ + +void +set_quit_flag (void) +{ +#ifdef HAVE_PYTHON + python_scripting_interface.set_quit_flag (); +#else + quit_flag = 1; +#endif +} + +/* Return true if the quit flag has been set, false otherwise. */ + +int +check_quit_flag (void) +{ +#ifdef HAVE_PYTHON + return python_scripting_interface.check_quit_flag (); +#else + /* This is written in a particular way to avoid races. */ + if (quit_flag) + { + quit_flag = 0; + return 1; + } + + return 0; +#endif +} + +/* Some code (MI) wants to know if a particular scripting language + successfully initialized. */ + +/* Return non-zero if Python scripting successfully initialized. */ + +int +slang_python_initialized (void) +{ +#ifdef HAVE_PYTHON + return python_scripting_interface.initialized (); +#else + return 0; +#endif +} + +/* Return non-zero if Scheme scripting successfully initialized. */ + +int +slang_scheme_initialized (void) +{ +#ifdef HAVE_SCHEME + return scheme_scripting_interface.initialized (); +#else + return 0; +#endif +} Index: scripting.h =================================================================== RCS file: scripting.h diff -N scripting.h --- /dev/null 1 Jan 1970 00:00:00 -0000 +++ scripting.h 6 Sep 2013 15:17:12 -0000 @@ -0,0 +1,195 @@ +/* Interface between gdb and its scripting languages. + + Copyright (C) 2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#ifndef SCRIPTING_H +#define SCRIPTING_H + +#include "mi/mi-cmds.h" /* For PRINT_NO_VALUES, etc. */ + +struct breakpoint_object; +struct command_line; +struct frame_info; +struct language_defn; +struct objfile; +struct type; +struct ui_file; +struct ui_out; +struct value; +struct value_print_options; + +typedef void slang_sourcer_func (FILE *, const char *); + +/* Python frame-filter status return values. */ + +enum py_bt_status + { + /* Return when an error has occurred in processing frame filters, + or when printing the stack. */ + PY_BT_ERROR = -1, + + /* Return from internal routines to indicate that the function + succeeded. */ + PY_BT_OK = 1, + + /* Return when the frame filter process is complete, and all + operations have succeeded. */ + PY_BT_COMPLETED = 2, + + /* Return when the frame filter process is complete, but there + were no filter registered and enabled to process. */ + PY_BT_NO_FILTERS = 3 + }; + +/* Flags to pass to apply_frame_filter. */ + +enum frame_filter_flags + { + /* Set this flag if frame level is to be printed. */ + PRINT_LEVEL = 1, + + /* Set this flag if frame information is to be printed. */ + PRINT_FRAME_INFO = 2, + + /* Set this flag if frame arguments are to be printed. */ + PRINT_ARGS = 4, + + /* Set this flag if frame locals are to be printed. */ + PRINT_LOCALS = 8, + }; + +/* A choice of the different frame argument printing strategies that + can occur in different cases of frame filter instantiation. */ + +enum py_frame_args + { + /* Print no values for arguments when invoked from the MI. */ + NO_VALUES = PRINT_NO_VALUES, + + MI_PRINT_ALL_VALUES = PRINT_ALL_VALUES, + + /* Print only simple values (what MI defines as "simple") for + arguments when invoked from the MI. */ + MI_PRINT_SIMPLE_VALUES = PRINT_SIMPLE_VALUES, + + /* Print only scalar values for arguments when invoked from the CLI. */ + CLI_SCALAR_VALUES, + + /* Print all values for arguments when invoked from the CLI. */ + CLI_ALL_VALUES + }; + +struct slang_type_printers +{ + void *py_type_printers; + void *scm_type_printers; +}; + +/* The interface between GDB and a scripting language. */ + +struct script_lang +{ + const char *name; + const char *capitalized_name; + const char *extension; + const char *auto_load_suffix; + + enum command_control_type cli_control_type; + + void (*finish_initialization) (void); + + int (*initialized) (void); + + slang_sourcer_func *source_script; + void (*eval_from_control_command) (struct command_line *); + void (*load_auto_scripts_for_objfile) (struct objfile *); + + void (*start_type_printers) (struct slang_type_printers *); + /* This function has a bit of a funny name, since it actually applies + recognizers, but this seemed clearer given the start_type_printers + and free_type_printers functions. */ + char *(*apply_type_printers) (const struct slang_type_printers *, + struct type *); + void (*free_type_printers) (struct slang_type_printers *); + + int (*apply_val_pretty_printer) (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); + + enum py_bt_status (*apply_frame_filter) (struct frame_info *frame, int flags, + enum py_frame_args args_type, + struct ui_out *out, + int frame_low, int frame_high); + + void (*preserve_values) (struct objfile *, htab_t copied_types); + + int (*breakpoint_has_cond) (struct breakpoint *); + int (*breakpoint_cond_says_stop) (struct breakpoint *); + + int (*check_quit_flag) (void); + void (*clear_quit_flag) (void); + void (*set_quit_flag) (void); + + /* TODO: varobj.c */ +}; + +/* Wrappers for each scripting API function. */ + +extern void finish_slang_initialization (void); + +extern slang_sourcer_func *get_slang_sourcer (const char *file); + +extern void eval_slang_from_control_command (struct command_line *cmd); + +extern void load_slang_auto_scripts_for_objfile (struct objfile *); + +extern struct slang_type_printers *start_slang_type_printers (void); + +extern char *apply_slang_type_printers (struct slang_type_printers *, + struct type *); + +extern void free_slang_type_printers (struct slang_type_printers *); + +extern int apply_val_slang_pretty_printer + (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 enum py_bt_status apply_slang_frame_filter + (struct frame_info *frame, int flags, enum py_frame_args args_type, + struct ui_out *out, int frame_low, int frame_high); + +extern void preserve_slang_values (struct objfile *, htab_t copied_types); + +extern int breakpoint_has_slang_cond (struct breakpoint *); + +extern int breakpoint_slang_cond_says_stop (struct breakpoint *); + +/* Return non-zero if Python scripting successfully initialized. */ +extern int slang_python_initialized (void); + +/* Return non-zero if Scheme scripting successfully initialized. */ +extern int slang_scheme_initialized (void); + +#endif /* SCRIPTING_H */ Index: stack.c =================================================================== RCS file: /cvs/src/src/gdb/stack.c,v retrieving revision 1.279 diff -u -p -r1.279 stack.c --- stack.c 20 Aug 2013 16:30:20 -0000 1.279 +++ stack.c 6 Sep 2013 15:17:12 -0000 @@ -1770,10 +1770,10 @@ backtrace_command_1 (char *count_exp, in else arg_type = NO_VALUES; - result = apply_frame_filter (get_current_frame (), flags, arg_type, - current_uiout, py_start, py_end); - + result = apply_slang_frame_filter (get_current_frame (), flags, arg_type, + current_uiout, py_start, py_end); } + /* Run the inbuilt backtrace if there are no filters registered, or "no-filters" has been specified from the command. */ if (no_filters || result == PY_BT_NO_FILTERS) Index: top.c =================================================================== RCS file: /cvs/src/src/gdb/top.c,v retrieving revision 1.241 diff -u -p -r1.241 top.c --- top.c 15 Aug 2013 08:18:31 -0000 1.241 +++ top.c 6 Sep 2013 15:17:12 -0000 @@ -1881,11 +1881,9 @@ gdb_init (char *argv0) if (deprecated_init_ui_hook) deprecated_init_ui_hook (argv0); -#ifdef HAVE_PYTHON /* Python initialization can require various commands to be installed. For example "info pretty-printer" needs the "info" prefix to be installed. Keep things simple and just do final python initialization here. */ - finish_python_initialization (); -#endif + finish_slang_initialization (); } Index: typeprint.c =================================================================== RCS file: /cvs/src/src/gdb/typeprint.c,v retrieving revision 1.53 diff -u -p -r1.53 typeprint.c --- typeprint.c 28 Mar 2013 17:25:47 -0000 1.53 +++ typeprint.c 6 Sep 2013 15:17:12 -0000 @@ -248,7 +248,7 @@ do_free_global_table (void *arg) struct type_print_options *flags = arg; free_typedef_hash (flags->global_typedefs); - free_type_printers (flags->global_printers); + free_slang_type_printers (flags->global_printers); } /* Create the global typedef hash. */ @@ -258,13 +258,13 @@ create_global_typedef_table (struct type { gdb_assert (flags->global_typedefs == NULL && flags->global_printers == NULL); flags->global_typedefs = create_typedef_hash (); - flags->global_printers = start_type_printers (); + flags->global_printers = start_slang_type_printers (); return make_cleanup (do_free_global_table, flags); } /* Look up the type T in the global typedef hash. If it is found, return the typedef name. If it is not found, apply the - type-printers, if any, given by start_type_printers and return the + type-printers, if any, given by start_slang_type_printers and return the result. A NULL return means that the name was not found. */ static const char * @@ -288,7 +288,7 @@ find_global_typedef (const struct type_p return new_tf->name; } - /* Put an entry into the hash table now, in case apply_type_printers + /* Put an entry into the hash table now, in case apply_slang_type_printers recurses. */ new_tf = XOBNEW (&flags->global_typedefs->storage, struct typedef_field); new_tf->name = NULL; @@ -296,7 +296,7 @@ find_global_typedef (const struct type_p *slot = new_tf; - applied = apply_type_printers (flags->global_printers, t); + applied = apply_slang_type_printers (flags->global_printers, t); if (applied != NULL) { Index: typeprint.h =================================================================== RCS file: /cvs/src/src/gdb/typeprint.h,v retrieving revision 1.17 diff -u -p -r1.17 typeprint.h --- typeprint.h 1 Jan 2013 06:41:29 -0000 1.17 +++ typeprint.h 6 Sep 2013 15:17:12 -0000 @@ -22,6 +22,7 @@ enum language; struct ui_file; struct typedef_hash_table; +struct slang_type_printers; struct type_print_options { @@ -44,7 +45,7 @@ struct type_print_options /* The list of type printers associated with the global typedef table. This is intentionally opaque. */ - void *global_printers; + struct slang_type_printers *global_printers; }; extern const struct type_print_options type_print_raw_options; Index: utils.c =================================================================== RCS file: /cvs/src/src/gdb/utils.c,v retrieving revision 1.306 diff -u -p -r1.306 utils.c --- utils.c 13 Aug 2013 08:31:20 -0000 1.306 +++ utils.c 6 Sep 2013 15:17:12 -0000 @@ -117,12 +117,6 @@ static int debug_timestamp = 0; int job_control; -#ifndef HAVE_PYTHON -/* Nonzero means a quit has been requested. */ - -int quit_flag; -#endif /* HAVE_PYTHON */ - /* Nonzero means quit immediately if Control-C is typed now, rather than waiting until QUIT is executed. Be careful in setting this; code which executes with immediate_quit set has to be very careful @@ -136,41 +130,6 @@ int quit_flag; int immediate_quit; -#ifndef HAVE_PYTHON - -/* Clear the quit flag. */ - -void -clear_quit_flag (void) -{ - quit_flag = 0; -} - -/* Set the quit flag. */ - -void -set_quit_flag (void) -{ - quit_flag = 1; -} - -/* Return true if the quit flag has been set, false otherwise. */ - -int -check_quit_flag (void) -{ - /* This is written in a particular way to avoid races. */ - if (quit_flag) - { - quit_flag = 0; - return 1; - } - - return 0; -} - -#endif /* HAVE_PYTHON */ - /* Nonzero means that strings with character values >0x7F should be printed as octal escapes. Zero means just print the value (e.g. it's an international character, and the terminal or window can cope.) */ Index: valprint.c =================================================================== RCS file: /cvs/src/src/gdb/valprint.c,v retrieving revision 1.138 diff -u -p -r1.138 valprint.c --- valprint.c 17 Jul 2013 20:35:11 -0000 1.138 +++ valprint.c 6 Sep 2013 15:17:12 -0000 @@ -761,9 +761,9 @@ val_print (struct type *type, const gdb_ if (!options->raw) { - ret = apply_val_pretty_printer (type, valaddr, embedded_offset, - address, stream, recurse, - val, options, language); + ret = apply_val_slang_pretty_printer (type, valaddr, embedded_offset, + address, stream, recurse, + val, options, language); if (ret) return; } @@ -858,12 +858,12 @@ value_print (struct value *val, struct u if (!options->raw) { - int r = apply_val_pretty_printer (value_type (val), - value_contents_for_printing (val), - value_embedded_offset (val), - value_address (val), - stream, 0, - val, options, current_language); + int r = apply_val_slang_pretty_printer (value_type (val), + value_contents_for_printing (val), + value_embedded_offset (val), + value_address (val), + stream, 0, + val, options, current_language); if (r) return; Index: value.c =================================================================== RCS file: /cvs/src/src/gdb/value.c,v retrieving revision 1.179 diff -u -p -r1.179 value.c --- value.c 5 Aug 2013 15:51:02 -0000 1.179 +++ value.c 6 Sep 2013 15:17:12 -0000 @@ -2230,7 +2230,7 @@ preserve_values (struct objfile *objfile for (var = internalvars; var; var = var->next) preserve_one_internalvar (var, objfile, copied_types); - preserve_python_values (objfile, copied_types); + preserve_slang_values (objfile, copied_types); htab_delete (copied_types); } Index: cli/cli-cmds.c =================================================================== RCS file: /cvs/src/src/gdb/cli/cli-cmds.c,v retrieving revision 1.159 diff -u -p -r1.159 cli-cmds.c --- cli/cli-cmds.c 17 Jul 2013 20:26:28 -0000 1.159 +++ cli/cli-cmds.c 6 Sep 2013 15:17:12 -0000 @@ -51,6 +51,7 @@ #include "cli/cli-utils.h" #include "python/python.h" +#include "scheme/scheme.h" #ifdef TUI #include "tui/tui.h" /* For tui_active et.al. */ @@ -522,23 +523,27 @@ find_and_open_script (const char *script static void source_script_from_stream (FILE *stream, const char *file) { - if (script_ext_mode != script_ext_off - && strlen (file) > 3 && !strcmp (&file[strlen (file) - 3], ".py")) + if (script_ext_mode != script_ext_off) { - volatile struct gdb_exception e; + slang_sourcer_func *sourcer = get_slang_sourcer (file); - TRY_CATCH (e, RETURN_MASK_ERROR) - { - source_python_script (stream, file); - } - if (e.reason < 0) + if (sourcer != NULL) { + volatile struct gdb_exception e; + + TRY_CATCH (e, RETURN_MASK_ERROR) + { + sourcer (stream, file); + } + if (e.reason >= 0) + return; /* Should we fallback to ye olde GDB script mode? */ if (script_ext_mode == script_ext_soft - && e.reason == RETURN_ERROR && e.error == UNSUPPORTED_ERROR) + && e.reason == RETURN_ERROR + && e.error == UNSUPPORTED_ERROR) { fseek (stream, 0, SEEK_SET); - script_from_file (stream, (char*) file); + /* Script is loaded below. */ } else { @@ -547,8 +552,8 @@ source_script_from_stream (FILE *stream, } } } - else - script_from_file (stream, file); + + script_from_file (stream, file); } /* Worker to perform the "source" command. @@ -1224,7 +1229,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); @@ -1849,7 +1854,7 @@ you must type \"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, @@ -1857,8 +1862,8 @@ With no argument, show definitions of al 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); Index: cli/cli-script.c =================================================================== RCS file: /cvs/src/src/gdb/cli/cli-script.c,v retrieving revision 1.84 diff -u -p -r1.84 cli-script.c --- cli/cli-script.c 1 Aug 2013 09:09:58 -0000 1.84 +++ cli/cli-script.c 6 Sep 2013 15:17:12 -0000 @@ -31,8 +31,8 @@ #include "cli/cli-decode.h" #include "cli/cli-script.h" #include "gdb_assert.h" - #include "python/python.h" +#include "scheme/scheme.h" #include "interps.h" /* Prototypes for local functions. */ @@ -255,6 +255,19 @@ print_command_lines (struct ui_out *uiou continue; } + if (list->control_type == scheme_control) + { + ui_out_field_string (uiout, NULL, "scheme"); + 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) */ @@ -556,6 +569,7 @@ execute_control_command (struct command_ break; } + case commands_control: { /* Breakpoint commands list, record the commands in the @@ -567,12 +581,12 @@ execute_control_command (struct command_ ret = commands_from_control_command (new_line, cmd); break; } + case python_control: - { - eval_python_from_control_command (cmd); - ret = simple_control; - break; - } + case scheme_control: + eval_slang_from_control_command (cmd); + ret = simple_control; + break; default: warning (_("Invalid control type in canned commands structure.")); @@ -1007,6 +1021,11 @@ process_next_line (char *p, struct comma here. */ *command = build_command_line (python_control, ""); } + else if (p_end - p == 6 && !strncmp (p, "scheme", 6)) + { + /* Note that we ignore the inline "scheme command" form here. */ + *command = build_command_line (scheme_control, ""); + } else if (p_end - p == 10 && !strncmp (p, "loop_break", 10)) { *command = (struct command_line *) @@ -1094,7 +1113,8 @@ recurse_read_control_structure (char * ( 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 != scheme_control, validator, closure); /* Just skip blanks and comments. */ @@ -1103,10 +1123,12 @@ recurse_read_control_structure (char * ( if (val == end_command) { + /* FIXME: make switch */ if (current_cmd->control_type == while_control || current_cmd->control_type == while_stepping_control || current_cmd->control_type == if_control || current_cmd->control_type == python_control + || current_cmd->control_type == scheme_control || current_cmd->control_type == commands_control) { /* Success reading an entire canned sequence of commands. */ @@ -1160,6 +1182,7 @@ recurse_read_control_structure (char * ( || next->control_type == while_stepping_control || next->control_type == if_control || next->control_type == python_control + || next->control_type == scheme_control || next->control_type == commands_control) { control_level++; @@ -1278,6 +1301,7 @@ read_command_lines_1 (char * (*read_next if (next->control_type == while_control || next->control_type == if_control || next->control_type == python_control + || next->control_type == scheme_control || next->control_type == commands_control || next->control_type == while_stepping_control) { Index: data-directory/Makefile.in =================================================================== RCS file: /cvs/src/src/gdb/data-directory/Makefile.in,v retrieving revision 1.17 diff -u -p -r1.17 Makefile.in --- data-directory/Makefile.in 22 Aug 2013 20:32:54 -0000 1.17 +++ data-directory/Makefile.in 6 Sep 2013 15:17:13 -0000 @@ -19,8 +19,9 @@ srcdir = @srcdir@ SYSCALLS_SRCDIR = $(srcdir)/../syscalls PYTHON_SRCDIR = $(srcdir)/../python/lib +SCHEME_SRCDIR = $(srcdir)/../scheme/lib SYSTEM_GDBINIT_SRCDIR = $(srcdir)/../system-gdbinit -VPATH = $(srcdir):$(SYSCALLS_SRCDIR):$(PYTHON_SRCDIR):$(SYSTEM_GDBINIT_SRCDIR) +VPATH = $(srcdir):$(SYSCALLS_SRCDIR):$(PYTHON_SRCDIR):$(SCHEME_SRCDIR):$(SYSTEM_GDBINIT_SRCDIR) top_srcdir = @top_srcdir@ top_builddir = @top_builddir@ @@ -70,6 +71,11 @@ PYTHON_FILES = \ gdb/function/__init__.py \ gdb/function/strfns.py +SCHEME_DIR = scheme +SCHEME_INSTALL_DIR = $(DESTDIR)$(GDB_DATADIR)/$(SCHEME_DIR) +SCHEME_FILES = \ + ./gdb.scm + SYSTEM_GDBINIT_DIR = system-gdbinit SYSTEM_GDBINIT_INSTALL_DIR = $(DESTDIR)$(GDB_DATADIR)/$(SYSTEM_GDBINIT_DIR) SYSTEM_GDBINIT_FILES = \ @@ -109,7 +115,7 @@ FLAGS_TO_PASS = \ "RUNTESTFLAGS=$(RUNTESTFLAGS)" .PHONY: all -all: stamp-syscalls stamp-python stamp-system-gdbinit +all: stamp-syscalls stamp-python stamp-scheme stamp-system-gdbinit # For portability's sake, we need to handle systems that don't have # symbolic links. @@ -193,6 +199,43 @@ uninstall-python: done \ done +stamp-scheme: Makefile $(SCHEME_FILES) + rm -rf ./$(SCHEME_DIR) + files='$(SCHEME_FILES)' ; \ + for file in $$files ; do \ + dir=`echo "$$file" | sed 's,/[^/]*$$,,'` ; \ + $(INSTALL_DIR) ./$(SCHEME_DIR)/$$dir ; \ + $(INSTALL_DATA) $(SCHEME_SRCDIR)/$$file ./$(SCHEME_DIR)/$$dir ; \ + done + touch $@ + +.PHONY: clean-scheme +clean-scheme: + rm -rf $(SCHEME_DIR) + rm -f stamp-scheme + +.PHONY: install-scheme +install-scheme: + files='$(SCHEME_FILES)' ; \ + for file in $$files ; do \ + dir=`echo "$$file" | sed 's,/[^/]*$$,,'` ; \ + $(INSTALL_DIR) $(SCHEME_INSTALL_DIR)/$$dir ; \ + $(INSTALL_DATA) ./$(SCHEME_DIR)/$$file $(SCHEME_INSTALL_DIR)/$$dir ; \ + done + +.PHONY: uninstall-scheme +uninstall-scheme: + files='$(SCHEME_FILES)' ; \ + for file in $$files ; do \ + slashdir=`echo "/$$file" | sed 's,/[^/]*$$,,'` ; \ + rm -f $(SCHEME_INSTALL_DIR)/$$file ; \ + while test "x$$file" != "x$$slashdir" ; do \ + rmdir 2>/dev/null "$(SCHEME_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) @@ -244,13 +287,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-scheme \ + install-system-gdbinit .PHONY: uninstall -uninstall: uninstall-syscalls uninstall-python uninstall-system-gdbinit +uninstall: uninstall-syscalls uninstall-python uninstall-scheme \ + uninstall-system-gdbinit .PHONY: clean -clean: clean-syscalls clean-python clean-system-gdbinit +clean: clean-syscalls clean-python clean-scheme clean-system-gdbinit .PHONY: maintainer-clean realclean distclean maintainer-clean realclean distclean: clean Index: mi/mi-cmd-stack.c =================================================================== RCS file: /cvs/src/src/gdb/mi/mi-cmd-stack.c,v retrieving revision 1.74 diff -u -p -r1.74 mi-cmd-stack.c --- mi/mi-cmd-stack.c 8 Aug 2013 05:10:10 -0000 1.74 +++ mi/mi-cmd-stack.c 6 Sep 2013 15:17:13 -0000 @@ -151,9 +151,9 @@ mi_cmd_stack_list_frames (char *command, if (py_frame_low == -1) py_frame_low++; - result = apply_frame_filter (get_current_frame (), flags, - NO_VALUES, current_uiout, - py_frame_low, frame_high); + result = apply_slang_frame_filter (get_current_frame (), flags, + NO_VALUES, current_uiout, + py_frame_low, frame_high); } /* Run the inbuilt backtrace if there are no filters registered, or @@ -257,8 +257,8 @@ mi_cmd_stack_list_locals (char *command, { int flags = PRINT_LEVEL | PRINT_LOCALS; - result = apply_frame_filter (frame, flags, print_value, - current_uiout, 0, 0); + result = apply_slang_frame_filter (frame, flags, print_value, + current_uiout, 0, 0); } /* Run the inbuilt backtrace if there are no filters registered, or @@ -332,9 +332,9 @@ mi_cmd_stack_list_args (char *command, c if (py_frame_low == -1) py_frame_low++; - result = apply_frame_filter (get_current_frame (), flags, - print_values, current_uiout, - py_frame_low, frame_high); + result = apply_slang_frame_filter (get_current_frame (), flags, + print_values, current_uiout, + py_frame_low, frame_high); } /* Run the inbuilt backtrace if there are no filters registered, or @@ -416,8 +416,8 @@ mi_cmd_stack_list_variables (char *comma { int flags = PRINT_LEVEL | PRINT_ARGS | PRINT_LOCALS; - result = apply_frame_filter (frame, flags, print_value, - current_uiout, 0, 0); + result = apply_slang_frame_filter (frame, flags, print_value, + current_uiout, 0, 0); } /* Run the inbuilt backtrace if there are no filters registered, or Index: mi/mi-main.c =================================================================== RCS file: /cvs/src/src/gdb/mi/mi-main.c,v retrieving revision 1.238 diff -u -p -r1.238 mi-main.c --- mi/mi-main.c 25 Jul 2013 10:39:39 -0000 1.238 +++ mi/mi-main.c 6 Sep 2013 15:17:13 -0000 @@ -52,9 +52,7 @@ #include "ctf.h" #include "ada-lang.h" #include "linespec.h" -#ifdef HAVE_PYTHON -#include "python/python-internal.h" -#endif +#include "scripting.h" #include #include @@ -1768,10 +1766,10 @@ mi_cmd_list_features (char *command, cha ui_out_field_string (uiout, NULL, "breakpoint-notifications"); ui_out_field_string (uiout, NULL, "ada-task-info"); -#if HAVE_PYTHON - if (gdb_python_initialized) + if (slang_python_initialized ()) ui_out_field_string (uiout, NULL, "python"); -#endif + if (slang_scheme_initialized ()) + ui_out_field_string (uiout, NULL, "scheme"); do_cleanups (cleanup); return; Index: python/py-auto-load.c =================================================================== RCS file: /cvs/src/src/gdb/python/py-auto-load.c,v retrieving revision 1.28 diff -u -p -r1.28 py-auto-load.c --- python/py-auto-load.c 20 May 2013 20:28:51 -0000 1.28 +++ python/py-auto-load.c 6 Sep 2013 15:17:13 -0000 @@ -218,7 +218,8 @@ auto_load_section_scripts (struct objfil } } -/* Load any Python auto-loaded scripts for OBJFILE. */ +/* Load any Python auto-loaded scripts for OBJFILE. + This is the main entry point in this file. */ void gdbpy_load_auto_scripts_for_objfile (struct objfile *objfile) @@ -285,11 +286,4 @@ Print the list of automatically loaded P return 0; } -#else /* ! HAVE_PYTHON */ - -void -gdbpy_load_auto_scripts_for_objfile (struct objfile *objfile) -{ -} - -#endif /* ! HAVE_PYTHON */ +#endif /* HAVE_PYTHON */ Index: python/py-breakpoint.c =================================================================== RCS file: /cvs/src/src/gdb/python/py-breakpoint.c,v retrieving revision 1.41 diff -u -p -r1.41 py-breakpoint.c --- python/py-breakpoint.c 30 May 2013 17:30:03 -0000 1.41 +++ python/py-breakpoint.c 6 Sep 2013 15:17:13 -0000 @@ -37,7 +37,7 @@ static int bppy_live; /* Variables used to pass information between the Breakpoint constructor and the breakpoint-created hook function. */ -breakpoint_object *bppy_pending_object; +gdbpy_breakpoint_object *bppy_pending_object; /* Function that is called when a Python condition is evaluated. */ static char * const stop_func = "stop"; @@ -76,7 +76,7 @@ static struct pybp_code pybp_watch_types static PyObject * bppy_is_valid (PyObject *self, PyObject *args) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; if (self_bp->bp) Py_RETURN_TRUE; @@ -87,7 +87,7 @@ bppy_is_valid (PyObject *self, PyObject static PyObject * bppy_get_enabled (PyObject *self, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; BPPY_REQUIRE_VALID (self_bp); if (! self_bp->bp) @@ -101,7 +101,7 @@ bppy_get_enabled (PyObject *self, void * static PyObject * bppy_get_silent (PyObject *self, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; BPPY_REQUIRE_VALID (self_bp); if (self_bp->bp->silent) @@ -113,7 +113,7 @@ bppy_get_silent (PyObject *self, void *c static int bppy_set_enabled (PyObject *self, PyObject *newvalue, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; int cmp; volatile struct gdb_exception except; @@ -153,7 +153,7 @@ bppy_set_enabled (PyObject *self, PyObje static int bppy_set_silent (PyObject *self, PyObject *newvalue, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; int cmp; BPPY_SET_REQUIRE_VALID (self_bp); @@ -184,7 +184,7 @@ bppy_set_silent (PyObject *self, PyObjec static int bppy_set_thread (PyObject *self, PyObject *newvalue, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; long id; BPPY_SET_REQUIRE_VALID (self_bp); @@ -225,7 +225,7 @@ bppy_set_thread (PyObject *self, PyObjec static int bppy_set_task (PyObject *self, PyObject *newvalue, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; long id; int valid_id = 0; volatile struct gdb_exception except; @@ -278,7 +278,7 @@ bppy_set_task (PyObject *self, PyObject static PyObject * bppy_delete_breakpoint (PyObject *self, PyObject *args) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; volatile struct gdb_exception except; BPPY_REQUIRE_VALID (self_bp); @@ -297,7 +297,7 @@ bppy_delete_breakpoint (PyObject *self, static int bppy_set_ignore_count (PyObject *self, PyObject *newvalue, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; long value; volatile struct gdb_exception except; @@ -335,7 +335,7 @@ bppy_set_ignore_count (PyObject *self, P static int bppy_set_hit_count (PyObject *self, PyObject *newvalue, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; BPPY_SET_REQUIRE_VALID (self_bp); @@ -370,7 +370,7 @@ static PyObject * bppy_get_location (PyObject *self, void *closure) { char *str; - breakpoint_object *obj = (breakpoint_object *) self; + gdbpy_breakpoint_object *obj = (gdbpy_breakpoint_object *) self; BPPY_REQUIRE_VALID (obj); @@ -389,7 +389,7 @@ static PyObject * bppy_get_expression (PyObject *self, void *closure) { char *str; - breakpoint_object *obj = (breakpoint_object *) self; + gdbpy_breakpoint_object *obj = (gdbpy_breakpoint_object *) self; struct watchpoint *wp; BPPY_REQUIRE_VALID (obj); @@ -411,7 +411,7 @@ static PyObject * bppy_get_condition (PyObject *self, void *closure) { char *str; - breakpoint_object *obj = (breakpoint_object *) self; + gdbpy_breakpoint_object *obj = (gdbpy_breakpoint_object *) self; BPPY_REQUIRE_VALID (obj); @@ -429,7 +429,7 @@ static int bppy_set_condition (PyObject *self, PyObject *newvalue, void *closure) { char *exp; - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; volatile struct gdb_exception except; BPPY_SET_REQUIRE_VALID (self_bp); @@ -466,7 +466,7 @@ bppy_set_condition (PyObject *self, PyOb static PyObject * bppy_get_commands (PyObject *self, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; struct breakpoint *bp = self_bp->bp; long length; volatile struct gdb_exception except; @@ -507,7 +507,7 @@ bppy_get_commands (PyObject *self, void static PyObject * bppy_get_type (PyObject *self, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; BPPY_REQUIRE_VALID (self_bp); @@ -519,7 +519,7 @@ bppy_get_type (PyObject *self, void *clo static PyObject * bppy_get_visibility (PyObject *self, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; BPPY_REQUIRE_VALID (self_bp); @@ -533,7 +533,7 @@ bppy_get_visibility (PyObject *self, voi static PyObject * bppy_get_number (PyObject *self, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; BPPY_REQUIRE_VALID (self_bp); @@ -544,7 +544,7 @@ bppy_get_number (PyObject *self, void *c static PyObject * bppy_get_thread (PyObject *self, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; BPPY_REQUIRE_VALID (self_bp); @@ -558,7 +558,7 @@ bppy_get_thread (PyObject *self, void *c static PyObject * bppy_get_task (PyObject *self, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; BPPY_REQUIRE_VALID (self_bp); @@ -572,7 +572,7 @@ bppy_get_task (PyObject *self, void *clo static PyObject * bppy_get_hit_count (PyObject *self, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; BPPY_REQUIRE_VALID (self_bp); @@ -583,7 +583,7 @@ bppy_get_hit_count (PyObject *self, void static PyObject * bppy_get_ignore_count (PyObject *self, void *closure) { - breakpoint_object *self_bp = (breakpoint_object *) self; + gdbpy_breakpoint_object *self_bp = (gdbpy_breakpoint_object *) self; BPPY_REQUIRE_VALID (self_bp); @@ -613,7 +613,7 @@ bppy_init (PyObject *self, PyObject *arg return -1; } - bppy_pending_object = (breakpoint_object *) self; + bppy_pending_object = (gdbpy_breakpoint_object *) self; bppy_pending_object->number = -1; bppy_pending_object->bp = NULL; @@ -662,7 +662,7 @@ bppy_init (PyObject *self, PyObject *arg return -1; } - BPPY_SET_REQUIRE_VALID ((breakpoint_object *) self); + BPPY_SET_REQUIRE_VALID ((gdbpy_breakpoint_object *) self); return 0; } @@ -720,17 +720,24 @@ gdbpy_breakpoints (PyObject *self, PyObj /* Call the "stop" method (if implemented) in the breakpoint class. If the method returns True, the inferior will be stopped at the breakpoint. Otherwise the inferior will be - allowed to continue. */ + allowed to continue (assuming other scripting language conditions + don't fire). */ int -gdbpy_should_stop (struct breakpoint_object *bp_obj) +gdbpy_breakpoint_cond_says_stop (struct breakpoint *b) { - int stop = 1; - + int stop; + struct gdbpy_breakpoint_object *bp_obj = b->py_bp_object; PyObject *py_bp = (PyObject *) bp_obj; - struct breakpoint *b = bp_obj->bp; - struct gdbarch *garch = b->gdbarch ? b->gdbarch : get_current_arch (); - struct cleanup *cleanup = ensure_python_env (garch, current_language); + struct gdbarch *garch; + struct cleanup *cleanup; + + if (bp_obj == NULL) + return 0; + + stop = 1; + garch = b->gdbarch ? b->gdbarch : get_current_arch (); + cleanup = ensure_python_env (garch, current_language); if (bp_obj->is_finish_bp) bpfinishpy_pre_stop_hook (bp_obj); @@ -765,22 +772,23 @@ gdbpy_should_stop (struct breakpoint_obj return stop; } -/* Checks if the "stop" method exists in this breakpoint. - Used by condition_command to ensure mutual exclusion of breakpoint - conditions. */ +/* Return TRUE if the "stop" method exists in this breakpoint. */ int -gdbpy_breakpoint_has_py_cond (struct breakpoint_object *bp_obj) +gdbpy_breakpoint_has_cond (struct breakpoint *b) { - int has_func = 0; - PyObject *py_bp = (PyObject *) bp_obj; - struct gdbarch *garch = bp_obj->bp->gdbarch ? bp_obj->bp->gdbarch : - get_current_arch (); - struct cleanup *cleanup = ensure_python_env (garch, current_language); - - if (py_bp != NULL) - has_func = PyObject_HasAttrString (py_bp, stop_func); - + int has_func; + PyObject *py_bp; + struct gdbarch *garch; + struct cleanup *cleanup; + + if (b->py_bp_object == NULL) + return 0; + + py_bp = (PyObject *) b->py_bp_object; + garch = b->gdbarch ? b->gdbarch : get_current_arch (); + cleanup = ensure_python_env (garch, current_language); + has_func = PyObject_HasAttrString (py_bp, stop_func); do_cleanups (cleanup); return has_func; @@ -795,7 +803,7 @@ gdbpy_breakpoint_has_py_cond (struct bre static void gdbpy_breakpoint_created (struct breakpoint *bp) { - breakpoint_object *newbp; + gdbpy_breakpoint_object *newbp; PyGILState_STATE state; if (bp->number < 0 && bppy_pending_object == NULL) @@ -816,7 +824,7 @@ gdbpy_breakpoint_created (struct breakpo bppy_pending_object = NULL; } else - newbp = PyObject_New (breakpoint_object, &breakpoint_object_type); + newbp = PyObject_New (gdbpy_breakpoint_object, &breakpoint_object_type); if (newbp) { newbp->number = bp->number; @@ -844,7 +852,7 @@ gdbpy_breakpoint_deleted (struct breakpo int num = b->number; PyGILState_STATE state; struct breakpoint *bp = NULL; - breakpoint_object *bp_obj; + gdbpy_breakpoint_object *bp_obj; state = PyGILState_Ensure (); bp = get_breakpoint (num); @@ -905,37 +913,6 @@ gdbpy_initialize_breakpoints (void) -/* Helper function that overrides this Python object's - PyObject_GenericSetAttr to allow extra validation of the attribute - being set. */ - -static int -local_setattro (PyObject *self, PyObject *name, PyObject *v) -{ - breakpoint_object *obj = (breakpoint_object *) self; - char *attr = python_string_to_host_string (name); - - if (attr == NULL) - return -1; - - /* If the attribute trying to be set is the "stop" method, - but we already have a condition set in the CLI, disallow this - operation. */ - if (strcmp (attr, stop_func) == 0 && obj->bp->cond_string) - { - xfree (attr); - PyErr_SetString (PyExc_RuntimeError, - _("Cannot set 'stop' method. There is an " \ - "existing GDB condition attached to the " \ - "breakpoint.")); - return -1; - } - - xfree (attr); - - return PyObject_GenericSetAttr ((PyObject *)self, name, v); -} - static PyGetSetDef breakpoint_object_getset[] = { { "enabled", bppy_get_enabled, bppy_set_enabled, "Boolean telling whether the breakpoint is enabled.", NULL }, @@ -989,7 +966,7 @@ PyTypeObject breakpoint_object_type = { PyVarObject_HEAD_INIT (NULL, 0) "gdb.Breakpoint", /*tp_name*/ - sizeof (breakpoint_object), /*tp_basicsize*/ + sizeof (gdbpy_breakpoint_object), /*tp_basicsize*/ 0, /*tp_itemsize*/ 0, /*tp_dealloc*/ 0, /*tp_print*/ @@ -1004,7 +981,7 @@ PyTypeObject breakpoint_object_type = 0, /*tp_call*/ 0, /*tp_str*/ 0, /*tp_getattro*/ - (setattrofunc)local_setattro, /*tp_setattro */ + 0, /*tp_setattro */ 0, /*tp_as_buffer*/ Py_TPFLAGS_DEFAULT | Py_TPFLAGS_BASETYPE, /*tp_flags*/ "GDB breakpoint object", /* tp_doc */ Index: python/py-finishbreakpoint.c =================================================================== RCS file: /cvs/src/src/gdb/python/py-finishbreakpoint.c,v retrieving revision 1.16 diff -u -p -r1.16 py-finishbreakpoint.c --- python/py-finishbreakpoint.c 20 May 2013 20:36:18 -0000 1.16 +++ python/py-finishbreakpoint.c 6 Sep 2013 15:17:13 -0000 @@ -39,7 +39,7 @@ static char * const outofscope_func = "o struct finish_breakpoint_object { /* gdb.Breakpoint base class. */ - breakpoint_object py_bp; + gdbpy_breakpoint_object py_bp; /* gdb.Type object of the value return by the breakpointed function. May be NULL if no debug information was available or return type was VOID. */ @@ -90,7 +90,7 @@ bpfinishpy_dealloc (PyObject *self) `return_value', if possible. */ void -bpfinishpy_pre_stop_hook (struct breakpoint_object *bp_obj) +bpfinishpy_pre_stop_hook (struct gdbpy_breakpoint_object *bp_obj) { struct finish_breakpoint_object *self_finishbp = (struct finish_breakpoint_object *) bp_obj; @@ -133,7 +133,7 @@ bpfinishpy_pre_stop_hook (struct breakpo of the gdb.FinishBreakpoint object BP_OBJ. */ void -bpfinishpy_post_stop_hook (struct breakpoint_object *bp_obj) +bpfinishpy_post_stop_hook (struct gdbpy_breakpoint_object *bp_obj) { volatile struct gdb_exception except; @@ -320,7 +320,7 @@ bpfinishpy_init (PyObject *self, PyObjec static void bpfinishpy_out_of_scope (struct finish_breakpoint_object *bpfinish_obj) { - breakpoint_object *bp_obj = (breakpoint_object *) bpfinish_obj; + gdbpy_breakpoint_object *bp_obj = (gdbpy_breakpoint_object *) bpfinish_obj; PyObject *py_obj = (PyObject *) bp_obj; if (bpfinish_obj->py_bp.bp->enable_state == bp_enabled Index: python/py-framefilter.c =================================================================== RCS file: /cvs/src/src/gdb/python/py-framefilter.c,v retrieving revision 1.1 diff -u -p -r1.1 py-framefilter.c --- python/py-framefilter.c 10 May 2013 10:26:02 -0000 1.1 +++ python/py-framefilter.c 6 Sep 2013 15:17:13 -0000 @@ -1454,11 +1454,9 @@ bootstrap_python_frame_filters (struct f or PY_BT_COMPLETED on success.*/ enum py_bt_status -apply_frame_filter (struct frame_info *frame, int flags, - enum py_frame_args args_type, - struct ui_out *out, int frame_low, - int frame_high) - +gdbpy_apply_frame_filter (struct frame_info *frame, int flags, + enum py_frame_args args_type, + struct ui_out *out, int frame_low, int frame_high) { struct gdbarch *gdbarch = NULL; struct cleanup *cleanups; Index: python/py-prettyprint.c =================================================================== RCS file: /cvs/src/src/gdb/python/py-prettyprint.c,v retrieving revision 1.36 diff -u -p -r1.36 py-prettyprint.c --- python/py-prettyprint.c 9 Jul 2013 16:57:09 -0000 1.36 +++ python/py-prettyprint.c 6 Sep 2013 15:17:13 -0000 @@ -300,7 +300,7 @@ print_stack_unless_memory_error (struct gdbpy_print_stack (); } -/* Helper for apply_val_pretty_printer which calls to_string and +/* Helper for gdbpy_apply_val_pretty_printer which calls to_string and formats the result. */ static enum string_repr_result @@ -467,7 +467,7 @@ push_dummy_python_frame (void) } #endif -/* Helper for apply_val_pretty_printer that formats children of the +/* Helper for gdbpy_apply_val_pretty_printer that formats children of the printer, if any exist. If is_py_none is true, then nothing has been printed by to_string, and format output accordingly. */ static void @@ -687,12 +687,12 @@ print_children (PyObject *printer, const } int -apply_val_pretty_printer (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) +gdbpy_apply_val_pretty_printer (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); PyObject *printer = NULL; @@ -839,17 +839,4 @@ gdbpy_default_visualizer (PyObject *self return cons; } -#else /* HAVE_PYTHON */ - -int -apply_val_pretty_printer (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) -{ - return 0; -} - #endif /* HAVE_PYTHON */ Index: python/py-value.c =================================================================== RCS file: /cvs/src/src/gdb/python/py-value.c,v retrieving revision 1.43 diff -u -p -r1.43 py-value.c --- python/py-value.c 30 May 2013 17:18:54 -0000 1.43 +++ python/py-value.c 6 Sep 2013 15:17:13 -0000 @@ -30,8 +30,6 @@ #include "cp-abi.h" #include "python.h" -#ifdef HAVE_PYTHON - #include "python-internal.h" /* Even though Python scalar types directly map to host types, we use @@ -163,7 +161,7 @@ valpy_new (PyTypeObject *subtype, PyObje /* Iterate over all the Value objects, calling preserve_one_value on each. */ void -preserve_python_values (struct objfile *objfile, htab_t copied_types) +gdbpy_preserve_values (struct objfile *objfile, htab_t copied_types) { value_object *iter; @@ -1534,13 +1532,3 @@ PyTypeObject value_object_type = { 0, /* tp_alloc */ valpy_new /* tp_new */ }; - -#else - -void -preserve_python_values (struct objfile *objfile, htab_t copied_types) -{ - /* Nothing. */ -} - -#endif /* HAVE_PYTHON */ Index: python/python-internal.h =================================================================== RCS file: /cvs/src/src/gdb/python/python-internal.h,v retrieving revision 1.78 diff -u -p -r1.78 python-internal.h --- python/python-internal.h 30 May 2013 08:56:56 -0000 1.78 +++ python/python-internal.h 6 Sep 2013 15:17:13 -0000 @@ -20,6 +20,8 @@ #ifndef GDB_PYTHON_INTERNAL_H #define GDB_PYTHON_INTERNAL_H +#include "scripting.h" + /* These WITH_* macros are defined by the CPython API checker that comes with the Python plugin for GCC. See: https://gcc-python-plugin.readthedocs.org/en/latest/cpychecker.html @@ -223,7 +225,7 @@ extern PyTypeObject breakpoint_object_ty extern PyTypeObject frame_object_type CPYCHECKER_TYPE_OBJECT_FOR_TYPEDEF ("frame_object"); -typedef struct breakpoint_object +typedef struct gdbpy_breakpoint_object { PyObject_HEAD @@ -236,7 +238,7 @@ typedef struct breakpoint_object /* 1 is this is a FinishBreakpoint object, 0 otherwise. */ int is_finish_bp; -} breakpoint_object; +} gdbpy_breakpoint_object; /* Require that BREAKPOINT be a valid breakpoint ID; throw a Python exception if it is invalid. */ @@ -263,7 +265,7 @@ typedef struct breakpoint_object /* Variables used to pass information between the Breakpoint constructor and the breakpoint-created hook function. */ -extern breakpoint_object *bppy_pending_object; +extern gdbpy_breakpoint_object *bppy_pending_object; typedef struct @@ -279,7 +281,33 @@ typedef struct extern struct cmd_list_element *set_python_list; extern struct cmd_list_element *show_python_list; - + +void gdbpy_finish_initialization (void); +int gdbpy_initialized (void); +slang_sourcer_func gdbpy_source_script; +void gdbpy_eval_from_control_command (struct command_line *cmd); +void gdbpy_load_auto_scripts_for_objfile (struct objfile *objfile); +void gdbpy_start_type_printers (struct slang_type_printers *); +char *gdbpy_apply_type_printers (const struct slang_type_printers *, + struct type *); +void gdbpy_free_type_printers (struct slang_type_printers *); +int gdbpy_apply_val_pretty_printer + (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); +enum py_bt_status gdbpy_apply_frame_filter + (struct frame_info *frame, int flags, enum py_frame_args args_type, + struct ui_out *out, int frame_low, int frame_high); +void gdbpy_preserve_values (struct objfile *objfile, htab_t copied_types); +int gdbpy_breakpoint_has_cond (struct breakpoint *); +int gdbpy_breakpoint_cond_says_stop (struct breakpoint *); +void gdbpy_clear_quit_flag (void); +void gdbpy_set_quit_flag (void); +int gdbpy_check_quit_flag (void); + PyObject *gdbpy_history (PyObject *self, PyObject *args); PyObject *gdbpy_breakpoints (PyObject *, PyObject *); PyObject *gdbpy_frame_stop_reason_string (PyObject *, PyObject *); @@ -461,8 +489,8 @@ PyObject *gdbpy_get_varobj_pretty_printe char *gdbpy_get_display_hint (PyObject *printer); PyObject *gdbpy_default_visualizer (PyObject *self, PyObject *args); -void bpfinishpy_pre_stop_hook (struct breakpoint_object *bp_obj); -void bpfinishpy_post_stop_hook (struct breakpoint_object *bp_obj); +void bpfinishpy_pre_stop_hook (struct gdbpy_breakpoint_object *bp_obj); +void bpfinishpy_post_stop_hook (struct gdbpy_breakpoint_object *bp_obj); extern PyObject *gdbpy_doc_cst; extern PyObject *gdbpy_children_cst; Index: python/python.c =================================================================== RCS file: /cvs/src/src/gdb/python/python.c,v retrieving revision 1.121 diff -u -p -r1.121 python.c --- python/python.c 18 Jun 2013 18:42:09 -0000 1.121 +++ python/python.c 6 Sep 2013 15:17:13 -0000 @@ -104,6 +104,41 @@ PyObject *gdbpy_gdb_error; /* The `gdb.MemoryError' exception. */ PyObject *gdbpy_gdb_memory_error; +/* The interface between gdb proper and python scripting. */ + +const struct script_lang python_scripting_interface = +{ + "python", + "Python", + ".py", + "-gdb.py", + python_control, + + gdbpy_finish_initialization, + gdbpy_initialized, + + gdbpy_source_script, + gdbpy_eval_from_control_command, + gdbpy_load_auto_scripts_for_objfile, + + gdbpy_start_type_printers, + gdbpy_apply_type_printers, + gdbpy_free_type_printers, + + gdbpy_apply_val_pretty_printer, + + gdbpy_apply_frame_filter, + + gdbpy_preserve_values, + + gdbpy_breakpoint_has_cond, + gdbpy_breakpoint_cond_says_stop, + + gdbpy_check_quit_flag, + gdbpy_clear_quit_flag, + gdbpy_set_quit_flag, +}; + /* Architecture and language to be used in callbacks from the Python interpreter. */ struct gdbarch *python_gdbarch; @@ -170,7 +205,7 @@ ensure_python_env (struct gdbarch *gdbar /* Clear the quit flag. */ void -clear_quit_flag (void) +gdbpy_clear_quit_flag (void) { /* This clears the flag as a side effect. */ PyOS_InterruptOccurred (); @@ -179,7 +214,7 @@ clear_quit_flag (void) /* Set the quit flag. */ void -set_quit_flag (void) +gdbpy_set_quit_flag (void) { PyErr_SetInterrupt (); } @@ -187,7 +222,7 @@ set_quit_flag (void) /* Return true if the quit flag has been set, false otherwise. */ int -check_quit_flag (void) +gdbpy_check_quit_flag (void) { return PyOS_InterruptOccurred (); } @@ -344,7 +379,7 @@ compute_python_string (struct command_li evaluate its body using the Python interpreter. */ void -eval_python_from_control_command (struct command_line *cmd) +gdbpy_eval_from_control_command (struct command_line *cmd) { int ret; char *script; @@ -770,7 +805,7 @@ gdbpy_find_pc_line (PyObject *self, PyOb the traceback and clear the error indicator. */ void -source_python_script (FILE *file, const char *filename) +gdbpy_source_script (FILE *file, const char *filename) { struct cleanup *cleanup; @@ -1225,18 +1260,18 @@ gdbpy_objfiles (PyObject *unused1, PyObj return list; } -/* Compute the list of active type printers and return it. The result - of this function can be passed to apply_type_printers, and should - be freed by free_type_printers. */ +/* Compute the list of active python type printers and store them in + SLANG_PRINTERS->py_type_printers. The product of this function is used by + gdbpy_apply_type_printers, and freed by gdbpy_free_type_printers. */ -void * -start_type_printers (void) +void +gdbpy_start_type_printers (struct slang_type_printers *slang_printers) { struct cleanup *cleanups; - PyObject *type_module, *func = NULL, *result_obj = NULL; + PyObject *type_module, *func = NULL, *printers_obj = NULL; if (!gdb_python_initialized) - return NULL; + return; cleanups = ensure_python_env (get_current_arch (), current_language); @@ -1254,32 +1289,30 @@ start_type_printers (void) goto done; } - result_obj = PyObject_CallFunctionObjArgs (func, (char *) NULL); - if (result_obj == NULL) + printers_obj = PyObject_CallFunctionObjArgs (func, (char *) NULL); + if (printers_obj == NULL) gdbpy_print_stack (); + else + slang_printers->py_type_printers = printers_obj; done: Py_XDECREF (type_module); Py_XDECREF (func); do_cleanups (cleanups); - return result_obj; } /* If TYPE is recognized by some type printer, return a newly allocated string holding the type's replacement name. The caller - is responsible for freeing the string. Otherwise, return NULL. - - This function has a bit of a funny name, since it actually applies - recognizers, but this seemed clearer given the start_type_printers - and free_type_printers functions. */ + is responsible for freeing the string. Otherwise, return NULL. */ char * -apply_type_printers (void *printers, struct type *type) +gdbpy_apply_type_printers (const struct slang_type_printers *slang_printers, + struct type *type) { struct cleanup *cleanups; PyObject *type_obj, *type_module = NULL, *func = NULL; PyObject *result_obj = NULL; - PyObject *printers_obj = printers; + PyObject *printers_obj = slang_printers->py_type_printers; char *result = NULL; if (printers_obj == NULL) @@ -1338,10 +1371,10 @@ apply_type_printers (void *printers, str /* Free the result of start_type_printers. */ void -free_type_printers (void *arg) +gdbpy_free_type_printers (struct slang_type_printers *slang_printers) { struct cleanup *cleanups; - PyObject *printers = arg; + PyObject *printers = slang_printers->py_type_printers; if (printers == NULL) return; @@ -1381,61 +1414,6 @@ python_command (char *arg, int from_tty) python_interactive_command (arg, from_tty); } -void -eval_python_from_control_command (struct command_line *cmd) -{ - error (_("Python scripting is not supported in this copy of GDB.")); -} - -void -source_python_script (FILE *file, const char *filename) -{ - throw_error (UNSUPPORTED_ERROR, - _("Python scripting is not supported in this copy of GDB.")); -} - -int -gdbpy_should_stop (struct breakpoint_object *bp_obj) -{ - internal_error (__FILE__, __LINE__, - _("gdbpy_should_stop called when Python scripting is " \ - "not supported.")); -} - -int -gdbpy_breakpoint_has_py_cond (struct breakpoint_object *bp_obj) -{ - internal_error (__FILE__, __LINE__, - _("gdbpy_breakpoint_has_py_cond called when Python " \ - "scripting is not supported.")); -} - -void * -start_type_printers (void) -{ - return NULL; -} - -char * -apply_type_printers (void *ignore, struct type *type) -{ - return NULL; -} - -void -free_type_printers (void *arg) -{ -} - -enum py_bt_status -apply_frame_filter (struct frame_info *frame, int flags, - enum py_frame_args args_type, - struct ui_out *out, int frame_low, - int frame_high) -{ - return PY_BT_NO_FILTERS; -} - #endif /* HAVE_PYTHON */ @@ -1735,7 +1713,7 @@ message == an error message without a st command installed. */ void -finish_python_initialization (void) +gdbpy_finish_initialization (void) { PyObject *m; char *gdb_pythondir; @@ -1816,6 +1794,12 @@ finish_python_initialization (void) #endif /* HAVE_PYTHON */ +int +gdbpy_initialized (void) +{ + return gdb_python_initialized; +} + #ifdef HAVE_PYTHON Index: python/python.h =================================================================== RCS file: /cvs/src/src/gdb/python/python.h,v retrieving revision 1.22 diff -u -p -r1.22 python.h --- python/python.h 10 May 2013 10:26:02 -0000 1.22 +++ python/python.h 6 Sep 2013 15:17:13 -0000 @@ -20,105 +20,15 @@ #ifndef GDB_PYTHON_H #define GDB_PYTHON_H -#include "value.h" -#include "mi/mi-cmds.h" - -struct breakpoint_object; +#include "scripting.h" /* The suffix of per-objfile scripts to auto-load. E.g. When the program loads libfoo.so, look for libfoo-gdb.py. */ +// TODO: xyzdje #define GDBPY_AUTO_FILE_NAME "-gdb.py" -/* Python frame-filter status return values. */ -enum py_bt_status - { - /* Return when an error has occurred in processing frame filters, - or when printing the stack. */ - PY_BT_ERROR = -1, - - /* Return from internal routines to indicate that the function - succeeded. */ - PY_BT_OK = 1, - - /* Return when the frame filter process is complete, and all - operations have succeeded. */ - PY_BT_COMPLETED = 2, - - /* Return when the frame filter process is complete, but there - were no filter registered and enabled to process. */ - PY_BT_NO_FILTERS = 3 - }; - -/* Flags to pass to apply_frame_filter. */ - -enum frame_filter_flags - { - /* Set this flag if frame level is to be printed. */ - PRINT_LEVEL = 1, - - /* Set this flag if frame information is to be printed. */ - PRINT_FRAME_INFO = 2, - - /* Set this flag if frame arguments are to be printed. */ - PRINT_ARGS = 4, - - /* Set this flag if frame locals are to be printed. */ - PRINT_LOCALS = 8, - }; - -/* A choice of the different frame argument printing strategies that - can occur in different cases of frame filter instantiation. */ -typedef enum py_frame_args -{ - /* Print no values for arguments when invoked from the MI. */ - NO_VALUES = PRINT_NO_VALUES, - - MI_PRINT_ALL_VALUES = PRINT_ALL_VALUES, - - /* Print only simple values (what MI defines as "simple") for - arguments when invoked from the MI. */ - MI_PRINT_SIMPLE_VALUES = PRINT_SIMPLE_VALUES, - - - /* Print only scalar values for arguments when invoked from the - CLI. */ - CLI_SCALAR_VALUES, - - /* Print all values for arguments when invoked from the - CLI. */ - CLI_ALL_VALUES -} py_frame_args; - -extern void finish_python_initialization (void); - -void eval_python_from_control_command (struct command_line *); - -void source_python_script (FILE *file, const char *filename); - -int apply_val_pretty_printer (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); - -enum py_bt_status apply_frame_filter (struct frame_info *frame, int flags, - enum py_frame_args args_type, - struct ui_out *out, int frame_low, - int frame_high); - -void preserve_python_values (struct objfile *objfile, htab_t copied_types); - -void gdbpy_load_auto_scripts_for_objfile (struct objfile *objfile); - -int gdbpy_should_stop (struct breakpoint_object *bp_obj); - -int gdbpy_breakpoint_has_py_cond (struct breakpoint_object *bp_obj); - -void *start_type_printers (void); - -char *apply_type_printers (void *, struct type *type); - -void free_type_printers (void *arg); +#ifdef HAVE_PYTHON +extern const struct script_lang python_scripting_interface; +#endif #endif /* GDB_PYTHON_H */ diff -rpN -U 2 scheme=/lib/gdb.scm scheme/lib/gdb.scm --- scheme=/lib/gdb.scm 1969-12-31 16:00:00.000000000 -0800 +++ scheme/lib/gdb.scm 2013-09-05 23:17:13.863964282 -0700 @@ -0,0 +1,18 @@ +;; Scheme gdb module. +;; +;; Copyright (C) 2013 Free Software Foundation, Inc. +;; +;; This file is part of GDB. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . diff -rpN -U 2 scheme=/scheme-internal.h scheme/scheme-internal.h --- scheme=/scheme-internal.h 1969-12-31 16:00:00.000000000 -0800 +++ scheme/scheme-internal.h 2013-09-06 07:51:16.873966493 -0700 @@ -0,0 +1,188 @@ +/* Internal header for gdb/scheme code. + + Copyright (C) 2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#ifndef GDB_SCHEME_INTERNAL_H +#define GDB_SCHEME_INTERNAL_H + +#include "scripting.h" +#include "libguile.h" +#include "scheme/scm-smobs.h" + +/* Scheme variables to define during initialization. */ + +typedef struct +{ + const char *name; + SCM value; +} scheme_variable; + +/* Scheme functions to define during initialization. */ + +typedef struct +{ + const char *name; + int required; + int optional; + int rest; + scm_t_subr func; +} scheme_function; + +/* 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)) + +/* __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 int gdb_scheme_initialized; + +extern SCM gdbscm_invalid_type_symbol; + +extern SCM gdbscm_map_string; +extern SCM gdbscm_array_string; +extern SCM gdbscm_string_string; + +extern void gdbscm_define_variables (const scheme_variable *, int public); + +extern void gdbscm_define_functions (const scheme_function *, int public); + +extern void gdbscm_printf (SCM port, const char *format, ...); + +extern void gdbscm_display (SCM obj); + +extern void gdbscm_parse_function_args (const char *function_name, + const char * const * keywords, + const char *format, ...); + +extern SCM gdbscm_c_to_scm_string (const char *string); + +extern char *gdbscm_scm_to_c_string (SCM string); + +extern SCM gdbscm_c_string_to_symbol (const char *symbol); + +extern char *gdbscm_scm_to_host_string (SCM string); + +extern SCM gdbscm_scm_string_to_target_scm_string (SCM string); + +extern char *gdbscm_scm_string_to_target_c_string (SCM string, size_t *length, + SCM *exception); + +extern int gdbscm_is_procedure (SCM proc); + +extern SCM gdbscm_make_exception (SCM tag, SCM args); + +extern int gdbscm_is_exception (SCM scm); + +extern void gdbscm_convert_gdb_exception (struct gdb_exception exception) + ATTRIBUTE_NORETURN; + +extern char *gdbscm_exception_to_string (SCM exception); + +extern int gdbscm_exception_matches_memory_error (SCM exception); + +extern void gdbscm_print_exception (SCM exception); + +extern void gdbscm_print_stack (void); + +extern SCM gdbscm_safe_call_0 (SCM proc); + +extern SCM gdbscm_safe_call_1 (SCM proc, SCM arg0); + +extern SCM gdbscm_safe_call_2 (SCM proc, SCM arg0, SCM arg1); + +extern SCM gdbscm_safe_apply_1 (SCM proc, SCM arg0, SCM args); + +extern SCM gdbscm_value_to_value_object (struct value *val); + +extern int gdbscm_is_type (SCM scm); + +extern int gdbscm_is_value (SCM scm); + +/* Simple iterator support. */ + +typedef struct +{ + gdb_smob base; + + SCM object; + SCM progress; + SCM next_x; +} iterator_smob; + +extern const char gdbscm_iterator_smob_name[]; + +extern SCM gdbscm_make_iterator (SCM object, SCM progress, SCM next); + +extern int gdbscm_is_iterator (SCM scm); + +/* stript_lang methods */ +extern void gdbscm_start_type_printers (struct slang_type_printers *); +extern char *gdbscm_apply_type_printers (const struct slang_type_printers *, + struct type *); +extern void gdbscm_free_type_printers (struct slang_type_printers *_printers); +extern void gdbscm_preserve_values (struct objfile *, htab_t copied_types); +extern int gdbscm_apply_val_pretty_printer + (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 (struct breakpoint *b); +extern int gdbscm_breakpoint_cond_says_stop (struct breakpoint *b); + +/* Initializers for each piece of Scheme support. */ +extern void gdbscm_initialize_breakpoints (void); +extern void gdbscm_initialize_exceptions (void); +extern void gdbscm_initialize_iterators (void); +extern void gdbscm_initialize_types (void); +extern void gdbscm_initialize_values (void); +extern void gdbscm_initialize_pretty_printers (void); + +/* Use this after a TRY_EXCEPT to throw the appropriate Scheme exception. */ +// FIXME:wip + +#define GDB_SCM_HANDLE_EXCEPTION(exception) \ + do { \ + if (exception.reason < 0) \ + { \ + gdbscm_convert_gdb_exception (exception); \ + /*NOTREACHED */ \ + } \ + } while (0) + +#endif /* GDB_SCHEME_INTERNAL_H */ diff -rpN -U 2 scheme=/scheme.c scheme/scheme.c --- scheme=/scheme.c 1969-12-31 16:00:00.000000000 -0800 +++ scheme/scheme.c 2013-09-06 08:02:10.843008946 -0700 @@ -0,0 +1,701 @@ +/* General gdb/scheme code. + + Copyright (C) 2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* Notes: + + Nomenclature: + We use Guile's implementation of Scheme, but that's an implementation + detail we shouldn't expose to the user. Therefore, we generally use + "scheme" or "scm" instead of "guile" in symbol names, and definitely for + everything user-facing. + + Importing: + You generally want to import the gdb module with a prefix. + E.g. (use-modules ((gdb) #:renamer (symbol-prefix-proc 'gdb:))) + This gives every symbol a "gdb:" prefix. +*/ + +/* WARNING: Uncaught Scheme exceptions are bad. + We protect against them as much as we can, but we're also careful to be + not overly cautious. + How expensive are simple operations by protecting them with scm_catch? */ + +/* INCOMPLETE TODO LIST: + - leaving out obvious things like missing functionality + - guile snarfing? + - review memory management of string wrappers + - error reporting: argument positions: origin 0 or 1? + - "gob", too close to "gdb" + - gsmob: can goops inherit from smobs? + - gsmob: gobj? gdbscm? gdbobj? + - gdb cleanups/exceptions vs Scheme exceptions, and their intermixing ... + - more catches, more scm_with_guile, ... + - stack printing + - lazy strings + - foo_assert_bar - Scheme uses the word "assert" to mean throw a Scheme + exception upon failure, not sure it'll be confusing in gdb/guile code + - our use of FUNC_NAME differs from Guile's + - the docs are conflicting on whether smob free functions have to free + the smob itself + - how is it decided a smob is no longer referenced? + - no more reference to the smob itself? + - no more reference to the "cell" that has the smob code + data ptr? + - audit gdbscm_make_exception calls + - audit GC of smobs + - ref vs get vs + - i18n +*/ + +/* Implementation notes: + - don't use scm_is_false, blech: they brought over () == #f from lisp +*/ + +#include "defs.h" +#include +#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 "scripting.h" +#include "utils.h" +#ifdef HAVE_SCHEME +#include "scheme/scheme.h" +#include "scheme/scheme-internal.h" +#endif + +#ifdef HAVE_SCHEME + +static void gdbscm_finish_initialization (void); +static int gdbscm_initialized (void); +static void gdbscm_eval_from_control_command (struct command_line *); +static slang_sourcer_func gdbscm_source_script; +static void gdbscm_load_auto_scripts_for_objfile (struct objfile *); + +int gdb_scheme_initialized; + +/* These symbols are needed. + To simplify things we record them in globals. + Storing them in globals is sufficient to protect them from the + garbage collector. */ +SCM gdbscm_invalid_type_symbol; + +/* Pretty-printer display hints are specified by strings. */ +SCM gdbscm_map_string; +SCM gdbscm_array_string; +SCM gdbscm_string_string; + +/* The name of the gdb module. */ +const char gdbscm_module_name[] = "gdb"; + +/* The interface between gdb proper and python scripting. */ + +const struct script_lang scheme_scripting_interface = +{ + "scheme", + "Scheme", + ".scm", + "-gdb.scm", + scheme_control, + + gdbscm_finish_initialization, + gdbscm_initialized, + + gdbscm_source_script, + gdbscm_eval_from_control_command, + gdbscm_load_auto_scripts_for_objfile, + + gdbscm_start_type_printers, + gdbscm_apply_type_printers, + 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, + + /* TODO: varobj.c */ +}; + +/* Evaluate a Scheme command, print the result of expressions, but don't + automatically print the stack on errors. */ + +static int +eval_scheme_command (const char *command) +{ + SCM result = scm_c_eval_string (command); + SCM port = scm_current_output_port (); + + scm_display (result, port); + /* Save the user from having to always add one. */ + scm_newline (port); + + return 0; +} + +/* Implementation of the gdb "scheme-interactive" command. */ + +static void +scheme_interactive_command (char *arg, int from_tty) +{ + struct cleanup *cleanup; + int err; + + cleanup = make_cleanup_restore_integer (&interpreter_async); + interpreter_async = 0; + + arg = skip_spaces (arg); + + /* TODO: 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) + { + if (0) + { + int len = strlen (arg); + char *script = xmalloc (len + 2); + + strcpy (script, arg); + script[len] = '\n'; + script[len + 1] = '\0'; + err = eval_scheme_command (script); + xfree (script); + } + else + error (_("scheme-interactive currently does not take any arguments")); + } + else + { + dont_repeat (); + /* It's unfortunate to have to resort to something like this, but + scm_shell doesn't return. :-( I found this in on guile-users@. */ + scm_call_1 (scm_c_public_ref ("system repl repl", "start-repl"), + scm_from_locale_symbol ("scheme")); + err = 0; + } + + if (err) + { + //gdbscm_print_stack (); - TODO, scm_display_error, or whatever + error (_("Error while executing Scheme code.")); + } + + do_cleanups (cleanup); +} + +/* Given a command_line, return a command string suitable for passing + to Scheme. 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; +} + +/* Wrapper to eval a C string in the Guile interpreter. */ + +static void * +eval_scheme_string (void *string) +{ + SCM result = scm_c_eval_string (string); + + return NULL; +} + +/* Implementation of the gdb "scheme" command. + Note: This doesn't display the result on purpose, for consistency with + Python. If the user wants something displayed, use (display ...). */ + +static void +scheme_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) + { + if (scm_with_guile (eval_scheme_string, arg)) + error (_("Error while executing Scheme code.")); + } + else + { + struct command_line *l = get_command_line (scheme_control, ""); + + make_cleanup_free_command_lines (&l); + execute_control_command_untraced (l); + } + + do_cleanups (cleanup); +} + +/* Take a command line structure representing a 'scheme' command, and + evaluate its body using the Scheme interpreter. + This is the script_lang.eval_from_control_command "method". */ + +static void +gdbscm_eval_from_control_command (struct command_line *cmd) +{ + void *ret; + char *script; + struct cleanup *cleanup; + + if (cmd->body_count != 1) + error (_("Invalid \"scheme\" block structure.")); + + cleanup = make_cleanup (null_cleanup, NULL); + + script = compute_scheme_string (cmd->body_list[0]); + ret = scm_with_guile (eval_scheme_string, script); + xfree (script); + if (ret) // FIXME + error (_("Error while executing Scheme code.")); + + do_cleanups (cleanup); +} + +/* scm_t_catch_body helper function for safe_source_scheme_script. */ + +static SCM +safe_source_scheme_script_body (void *data) +{ + const char *filename = data; + + /* FIXME: 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 (filename); + + /* If we get here the load succeeded. */ + return SCM_BOOL_F; +} + +/* scm_t_catch_handler helper function for safe_source_scheme_script. */ + +static SCM +safe_source_scheme_script_handler (void *data, SCM key, SCM args) +{ + return args; +} + +/* Try to load a script, catching all errors. + The result is #f if the load succeeded, otherwise it is the 4-argument + error spec: (subr, message, args, rest). */ + +static SCM +safe_source_scheme_script (const char *filename) +{ + char *data = (char*) filename; + SCM status; + + /* Pass SCM_BOOL_T for tag to catch all errors. */ + status = scm_c_catch (SCM_BOOL_T, safe_source_scheme_script_body, data, + safe_source_scheme_script_handler, NULL, + NULL, NULL); + + return status; +} + +/* Read a file as Scheme code. + This is the script_lang.source_script "method". + FILE is the file to run. FILENAME is name of the file FILE. + This does not throw any errors. If an exception occurs python will print + the traceback and clear the error indicator. */ + +static void +gdbscm_source_script (FILE *file, const char *filename) +{ + SCM status = safe_source_scheme_script (filename); + + //TODO: print error message? +} + +/* Load any Scheme auto-loaded scripts for OBJFILE. + This is the script_lang.load_auto_scripts_for_objfile "method". */ + +static void +gdbscm_load_auto_scripts_for_objfile (struct objfile *objfile) +{ + //TODO +} + +/* A Scheme function which evaluates a string using the gdb CLI. */ + +static SCM +execute_gdb_command (SCM command_scm, SCM rest) +{ + int from_tty = 0, to_string = 0; + volatile struct gdb_exception except; + static const char * const keywords[] = + { + "from-tty", "to-string", NULL + }; + char *command; + char *result = NULL; + const char *function_name = "(gdb execute)"; + + gdbscm_parse_function_args (function_name, keywords, "s#tt", + command_scm, &command, rest, + &from_tty, &to_string); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + /* Copy the argument text in case the command modifies it. */ + char *copy = xstrdup (command); + struct cleanup *cleanup = make_cleanup (xfree, copy); + + xfree (command); + make_cleanup_restore_integer (&interpreter_async); + interpreter_async = 0; + + prevent_dont_repeat (); + if (to_string) + result = execute_command_to_string (copy, from_tty); + else + { + execute_command (copy, from_tty); + result = NULL; + } + + do_cleanups (cleanup); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + /* Do any commands attached to breakpoint we stopped at. */ + bpstat_do_actions (); + + if (result) + { + SCM r = gdbscm_c_to_scm_string (result); + xfree (result); + return r; + } + return SCM_UNSPECIFIED; +} + +#else /* ! HAVE_SCHEME */ + +/* Dummy implementation of the gdb "scheme-interactive" and "scheme" + command. */ + +static void +scheme_interactive_command (char *arg, int from_tty) +{ + arg = skip_spaces (arg); + if (arg && *arg) + error (_("Scheme scripting is not supported in this copy of GDB.")); + else + { + struct command_line *l = get_command_line (scheme_control, ""); + struct cleanup *cleanups = make_cleanup_free_command_lines (&l); + + execute_control_command_untraced (l); + do_cleanups (cleanups); + } +} + +static void +scheme_command (char *arg, int from_tty) +{ + scheme_interactive_command (arg, from_tty); +} + +#endif /* ! HAVE_SCHEME */ + +/* Lists for 'set,show,info scheme' commands. */ + +static struct cmd_list_element *set_scheme_list; +static struct cmd_list_element *show_scheme_list; +static struct cmd_list_element *info_scheme_list; + +/* Function for use by 'set scheme' prefix command. */ + +static void +set_scheme_command (char *args, int from_tty) +{ + help_list (set_scheme_list, "set scheme ", all_commands, + gdb_stdout); +} + +/* Function for use by 'show scheme' prefix command. */ + +static void +show_scheme_command (char *args, int from_tty) +{ + cmd_show_list (show_scheme_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_scheme_command (char *args, int from_tty) +{ + printf_unfiltered (_("\"info scheme\" must be followed" + " by the name of an info command.\n")); + help_list (info_scheme_list, "info scheme ", -1, gdb_stdout); +} + +/* Initialization. */ + +#ifdef HAVE_SCHEME + +/* 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_c_define_gsubr (sf->name, sf->required, sf->optional, sf->rest, + sf->func); + if (public) + scm_c_export (sf->name, NULL); + } +} + +/* Install the gdb scheme module. + The result is a boolean indicating success. + If initializing the gdb module fails an error message is printed. */ + +static void +initialize_gdb_module (void *data) +{ + char *gdb_scheme_dir = concat (gdb_datadir, SLASH_STRING, "scheme", NULL); + char *gdb_module_file = concat (gdb_scheme_dir, SLASH_STRING, "gdb.scm", + NULL); + SCM status; + + /* The smob support must be initialized early. */ + gdbscm_initialize_smobs (); + gdbscm_initialize_exceptions (); + gdbscm_initialize_breakpoints (); + gdbscm_initialize_iterators (); + gdbscm_initialize_pretty_printers (); + gdbscm_initialize_types (); + gdbscm_initialize_values (); + + scm_c_define_gsubr ("execute", 1, 0, 1, execute_gdb_command); + + gdbscm_invalid_type_symbol = gdbscm_c_string_to_symbol ("invalid-type"); + + gdbscm_map_string = scm_from_utf8_string ("map"); + gdbscm_array_string = scm_from_utf8_string ("array"); + gdbscm_string_string = scm_from_utf8_string ("string"); + + status = safe_source_scheme_script (gdb_module_file); + + if (gdbscm_is_true (status)) + { + /* Some robustness checking before we start accessing STATUS. */ + if (scm_list_p (status) && scm_ilength (status) >= 3) + { + SCM message = scm_list_ref (status, scm_from_signed_integer (1)); + SCM args = scm_list_ref (status, scm_from_signed_integer (2)); + + scm_display_error_message (message, args, + scm_current_output_port ()); + } + else + { + SCM port = scm_current_output_port (); + + printf_filtered (_("Unknown failure loading gdb module:\n")); + scm_display (status, port); + scm_newline (port); + } + warning (_("\n" + "Could not complete Scheme gdb module initialization from:\n" + "%s.\n" + "Limited Scheme support is available.\n" + "Suggest passing --data-directory=/path/to/gdb/data-directory.\n"), + gdb_module_file); + } + + xfree (gdb_module_file); + xfree (gdb_scheme_dir); + + gdb_scheme_initialized = 1; +} + +/* A callback to finish Guile initialization after gdb has finished all its + initialization. + This is the script_lang.finish_initialization "method". */ + +static void +gdbscm_finish_initialization (void) +{ + /* Restore the environment to the user interaction one. */ + scm_set_current_module (scm_interaction_environment ()); +} + +/* The script_lang.initialized "method". */ + +static int +gdbscm_initialized (void) +{ + return gdb_scheme_initialized; +} + +#endif /* HAVE_SCHEME */ + +/* Install the various gdb commands used by Scheme. */ + +static void +install_gdb_commands (void) +{ + add_com ("scheme-interactive", class_obscure, + scheme_interactive_command, +#ifdef HAVE_SCHEME + _("\ +Start an interactive Scheme prompt.\n\ +\n\ +To return to GDB, type the EOF character (e.g., Ctrl-D on an empty\n\ +prompt).\n\ +\n\ +Alternatively, a single-line Scheme command can be given as an\n\ +argument, and if the command is an expression, the result will be\n\ +printed. For example:\n\ +\n\ + (gdb) scheme-interactive (2 + 3)\n\ + 5\n\ +") +#else /* HAVE_SCHEME */ + _("\ +Start a Scheme interactive prompt.\n\ +\n\ +Scheme scripting is not supported in this copy of GDB.\n\ +This command is only a placeholder.") +#endif /* HAVE_SCHEME */ + ); + add_com_alias ("scmi", "scheme-interactive", class_obscure, 1); + + add_com ("scheme", class_obscure, scheme_command, +#ifdef HAVE_SCHEME + _("\ +Evaluate a Scheme command.\n\ +\n\ +The command can be given as an argument, for instance:\n\ +\n\ + scheme (print 23) ;;FIXME\n\ +\n\ +If no argument is given, the following lines are read and used\n\ +as the Scheme commands. Type a line containing \"end\" to indicate\n\ +the end of the command.") +#else /* HAVE_SCHEME */ + _("\ +Evaluate a Scheme command.\n\ +\n\ +Scheme scripting is not supported in this copy of GDB.\n\ +This command is only a placeholder.") +#endif /* HAVE_SCHEME */ + ); + add_com_alias ("scm", "scheme", class_obscure, 1); + + add_prefix_cmd ("scheme", class_obscure, set_scheme_command, + _("Prefix command for scheme preference settings."), + &set_scheme_list, "set scheme ", 0, + &setlist); + add_alias_cmd ("scm", "scheme", class_obscure, 1, &setlist); + + add_prefix_cmd ("scheme", class_obscure, show_scheme_command, + _("Prefix command for scheme preference settings."), + &show_scheme_list, "show scheme ", 0, + &showlist); + add_alias_cmd ("scm", "scheme", class_obscure, 1, &showlist); + + add_prefix_cmd ("scheme", class_obscure, info_scheme_command, + _("Prefix command for scheme info displays."), + &info_scheme_list, "info scheme ", 0, + &infolist); + add_info_alias ("scm", "scheme", 1); +} + +/* Provide a prototype to silence -Wmissing-prototypes. */ +extern initialize_file_ftype _initialize_scheme; + +void +_initialize_scheme (void) +{ + install_gdb_commands (); + +#if HAVE_SCHEME + /* 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 (); + scm_c_eval_string ("(define-module (gdb) #:version (0))"); + scm_c_define_module ("gdb", initialize_gdb_module, NULL); +#endif +} diff -rpN -U 2 scheme=/scheme.h scheme/scheme.h --- scheme=/scheme.h 1969-12-31 16:00:00.000000000 -0800 +++ scheme/scheme.h 2013-09-06 07:54:22.152978521 -0700 @@ -0,0 +1,34 @@ +/* General gdb/scheme code. + + Copyright (C) 2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#ifndef GDB_SCHEME_H +#define GDB_SCHEME_H + +#include "scripting.h" + +/* The suffix of per-objfile scripts to auto-load. + E.g. When the program loads libfoo.so, look for libfoo-gdb.scm. */ +// TODO: xyzdje +#define GDBSCM_AUTO_FILE_NAME "-gdb.scm" + +#ifdef HAVE_SCHEME +extern const struct script_lang scheme_scripting_interface; +#endif + +#endif /* GDB_SCHEME_H */ diff -rpN -U 2 scheme=/scm-breakpoint.c scheme/scm-breakpoint.c --- scheme=/scm-breakpoint.c 1969-12-31 16:00:00.000000000 -0800 +++ scheme/scm-breakpoint.c 2013-09-06 07:51:53.476968869 -0700 @@ -0,0 +1,948 @@ +/* gdb/scheme interface to breakpoints + + Copyright (C) 2008-2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#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 "scheme-internal.h" + +/* The name of this typedef 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 SCM. + 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; + +/* Variable used to pass information between the breakpoint_smob + constructor and the breakpoint-created hook function. */ +static SCM pending_breakpoint_smob = SCM_BOOL_F; + +/* This is used to initialize various gdb.bp_* constants. */ +struct scmbp_code +{ + /* The name. */ + const char *name; + /* The code. */ + int code; +}; + +#define ASSERT_VALID_BKPT(self, bp_smob, func_name) \ + do { \ + assert_is_breakpoint ((self), (func_name)); \ + bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (self); \ + assert_is_valid_breakpoint ((bp_smob), (func_name), (self)); \ + } while (0) + +/* Entries related to the type of user set breakpoints. */ + +static const struct scmbp_code scmbp_codes[] = +{ + { "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 }, + { NULL } /* Sentinel. */ +}; + +/* Entries related to the type of watchpoint. */ + +static const struct scmbp_code scmbp_watch_types[] = +{ + { "WP_READ", hw_read }, + { "WP_WRITE", hw_write }, + { "WP_ACCESS", hw_access }, + { NULL } /* Sentinel. */ +}; + +static SCM +mark_breakpoint_smob (SCM smob) +{ + breakpoint_smob *bp_smob = + (breakpoint_smob *) SCM_SMOB_DATA (smob); + + scm_gc_mark (bp_smob->containing_scm); + scm_gc_mark (bp_smob->stop); + /* Do this last. */ + return gdbscm_mark_gsmob (&bp_smob->base); +} + +static size_t +free_breakpoint_smob (SCM smob) +{ + breakpoint_smob *bp_smob = + (breakpoint_smob *) SCM_SMOB_DATA (smob); + + if (bp_smob->bp) + bp_smob->bp->scm_bp_object = NULL; + return 0; +} + +static int +print_breakpoint_smob (SCM smob, SCM port, scm_print_state *pstate) +{ + breakpoint_smob *bp_smob = + (breakpoint_smob *) SCM_SMOB_DATA (smob); + + gdbscm_printf (port, "#<%s ", breakpoint_smob_name); + + // TODO: What else to display? + + scm_puts (">", port); + + scm_remember_upto_here_1 (smob); + + /* Non-zero means success. */ + return 1; +} + +static SCM +make_breakpoint_smob (void) +{ + breakpoint_smob *bp_smob = (breakpoint_smob *) + scm_gc_malloc (sizeof (breakpoint_smob), breakpoint_smob_name); + SCM smob; + + bp_smob->number = -1; + bp_smob->bp = NULL; + bp_smob->stop = SCM_BOOL_F; + smob = scm_new_smob (breakpoint_smob_tag, (scm_t_bits) bp_smob); + bp_smob->containing_scm = smob; + gdbscm_init_gsmob (smob, &bp_smob->base, breakpoint_smob_name); + + return smob; +} + +/* Return non-zero if SCM is a breakpoint smob. */ + +static int +gdbscm_is_breakpoint (SCM scm) +{ + if (SCM_IMP (scm)) + return 0; + return SCM_TYP16 (scm) == breakpoint_smob_tag; +} + +static SCM +gdbscm_breakpoint_p (SCM scm) +{ + return scm_from_bool (gdbscm_is_breakpoint (scm)); +} + +/* Return non-zero if breakpoint B is valid. */ + +static int +bpscm_is_valid (breakpoint_smob *self_bp) +{ + return self_bp->bp != NULL; +} + +/* Throw a Scheme error if SELF is not a breakpoint smob. */ + +static void +assert_is_breakpoint (SCM self, const char *func_name) +{ + SCM_ASSERT_TYPE (gdbscm_is_breakpoint (self), self, 0, func_name, + breakpoint_smob_name); +} + +/* Throw a Scheme error if SELF_BP is not a valid breakpoint smob. */ + +static void +assert_is_valid_breakpoint (breakpoint_smob *self_bp, + const char *func_name, SCM self) +{ + if (!bpscm_is_valid (self_bp)) + scm_misc_error (func_name, "invalid breakpoint", self); +} + +/* Scheme function which checks the validity of a breakpoint object. */ + +static SCM +bpscm_valid_p (SCM self) +{ + breakpoint_smob *self_bp; + + assert_is_breakpoint (self, FUNC_NAME); + self_bp = (breakpoint_smob *) SCM_SMOB_DATA (self); + + return scm_from_bool (bpscm_is_valid (self_bp)); +} + +/* Scheme function to test whether or not the breakpoint is enabled. */ + +static SCM +bpscm_enabled_p (SCM self) +{ + breakpoint_smob *self_bp; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + return scm_from_bool (self_bp->bp->enable_state == bp_enabled); +} + +/* Scheme function to set the enabled state of a breakpoint. */ + +static SCM +bpscm_set_enabled_x (SCM self, SCM newvalue) +{ + breakpoint_smob *self_bp; + volatile struct gdb_exception except; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue), newvalue, 1, FUNC_NAME, + "boolean"); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + if (gdbscm_is_true (newvalue)) + enable_breakpoint (self_bp->bp); + else + disable_breakpoint (self_bp->bp); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + return SCM_UNSPECIFIED; +} + +/* Scheme function to test whether or not the breakpoint is silent. */ + +static SCM +bpscm_silent_p (SCM self) +{ + breakpoint_smob *self_bp; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + return scm_from_bool (self_bp->bp->silent); +} + +/* Scheme function to set the 'silent' state of a breakpoint. */ + +static SCM +bpscm_set_silent_x (SCM self, SCM newvalue) +{ + breakpoint_smob *self_bp; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + SCM_ASSERT_TYPE (gdbscm_is_bool (newvalue), newvalue, 1, FUNC_NAME, + "boolean"); + + breakpoint_set_silent (self_bp->bp, gdbscm_is_true (newvalue)); + + return SCM_UNSPECIFIED; +} + +/* Scheme function to get the breakpoint's ignore count. */ + +static SCM +bpscm_ref_ignore_count (SCM self) +{ + breakpoint_smob *self_bp; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + return scm_from_long (self_bp->bp->ignore_count); +} + +/* Scheme function to set the ignore count of a breakpoint. */ + +static SCM +bpscm_set_ignore_count_x (SCM self, SCM newvalue) +{ + breakpoint_smob *self_bp; + long value; + volatile struct gdb_exception except; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + if (!scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX)) + scm_misc_error (FUNC_NAME, "ignore_count must be an integer", newvalue); + + value = scm_to_long (newvalue); + if (value < 0) + value = 0; + + TRY_CATCH (except, RETURN_MASK_ALL) + { + set_ignore_count (self_bp->number, (int) value, 0); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + return SCM_UNSPECIFIED; +} + +/* Scheme function to get the breakpoint's hit count. */ + +static SCM +bpscm_ref_hit_count (SCM self) +{ + breakpoint_smob *self_bp; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + return scm_from_long (self_bp->bp->hit_count); +} + +/* Scheme function to set the hit count of a breakpoint. */ + +static SCM +bpscm_set_hit_count_x (SCM self, SCM newvalue) +{ + breakpoint_smob *self_bp; + long value; + volatile struct gdb_exception except; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + if (!scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX)) + scm_misc_error (FUNC_NAME, "hit_count must be an integer", newvalue); + + value = scm_to_long (newvalue); + if (value < 0) + value = 0; + + if (value != 0) + scm_misc_error (FUNC_NAME, "hit_count must be zero", newvalue); + + self_bp->bp->hit_count = 0; + + return SCM_UNSPECIFIED; +} + +/* Scheme function to get the breakpoint's thread ID. */ + +static SCM +bpscm_ref_thread (SCM self) +{ + breakpoint_smob *self_bp; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + if (self_bp->bp->thread == -1) + return SCM_BOOL_F; + + return scm_from_long (self_bp->bp->thread); +} + +/* Scheme function to set the thread of a breakpoint. */ + +static SCM +bpscm_set_thread_x (SCM self, SCM newvalue) +{ + breakpoint_smob *self_bp; + long id; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + if (scm_is_signed_integer (newvalue, LONG_MIN, LONG_MAX)) + { + id = scm_to_long (newvalue); + if (! valid_thread_id (id)) + scm_misc_error (FUNC_NAME, "invalid thread id", newvalue); + } + else if (newvalue == SCM_BOOL_F) + id = -1; + else + { + scm_misc_error (FUNC_NAME, "thread id must be an integer or #f", + newvalue); + } + + breakpoint_set_thread (self_bp->bp, id); + + return SCM_UNSPECIFIED; +} + +/* Scheme function to get the breakpoint's task ID (in Ada). */ + +static SCM +bpscm_ref_task (SCM self) +{ + breakpoint_smob *self_bp; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + if (self_bp->bp->task == 0) + return SCM_BOOL_F; + + return scm_from_long (self_bp->bp->task); +} + +/* Scheme function to set the (Ada) task of a breakpoint. */ + +static SCM +bpscm_set_task_x (SCM self, SCM newvalue) +{ + breakpoint_smob *self_bp; + long id; + int valid_id = 0; + volatile struct gdb_exception except; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + 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); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + if (! valid_id) + scm_misc_error (FUNC_NAME, "invalid task id", newvalue); + } + else if (newvalue == SCM_BOOL_F) + id = 0; + else + scm_misc_error (FUNC_NAME, "task id must be an integer or #f", newvalue); + + breakpoint_set_task (self_bp->bp, id); + + return SCM_UNSPECIFIED; +} + +/* Scheme function to get the location of a breakpoint. */ + +static SCM +bpscm_ref_location (SCM self) +{ + breakpoint_smob *self_bp; + char *str; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + if (self_bp->bp->type != bp_breakpoint) + return SCM_BOOL_F; + + str = self_bp->bp->addr_string; + if (! str) + str = ""; + + //TODO: host charset + return gdbscm_c_to_scm_string (str); +} + +/* Scheme function to get the breakpoint expression. */ + +static SCM +bpscm_ref_expression (SCM self) +{ + breakpoint_smob *self_bp; + char *str; + struct watchpoint *wp; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + if (!is_watchpoint (self_bp->bp)) + return SCM_BOOL_F; + + wp = (struct watchpoint *) self_bp->bp; + + str = wp->exp_string; + if (! str) + str = ""; + + //TODO: host charset + return gdbscm_c_to_scm_string (str); +} + +/* Scheme function to get the condition expression of a breakpoint. */ + +static SCM +bpscm_ref_condition (SCM self) +{ + breakpoint_smob *self_bp; + char *str; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + str = self_bp->bp->cond_string; + if (! str) + return SCM_BOOL_F; + + //TODO: host charset + return gdbscm_c_to_scm_string (str); +} + +/* Scheme function to set the condition of a breakpoint. */ + +static SCM +bpscm_set_condition_x (SCM self, SCM newvalue) +{ + breakpoint_smob *self_bp; + char *exp; + volatile struct gdb_exception except; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + SCM_ASSERT_TYPE (scm_is_string (newvalue), newvalue, 1, FUNC_NAME, "string"); + + if (gdbscm_is_false (newvalue)) + exp = NULL; + else + { + //TODO: host charset + exp = gdbscm_scm_to_c_string (newvalue); + } + + TRY_CATCH (except, RETURN_MASK_ALL) + { + set_breakpoint_condition (self_bp->bp, exp ? exp : "", 0); + } + + xfree (exp); + + GDB_SCM_HANDLE_EXCEPTION (except); + + return SCM_UNSPECIFIED; +} + +/* Scheme function to get the commands attached to a breakpoint. */ + +static SCM +bpscm_ref_commands (SCM self) +{ + breakpoint_smob *self_bp; + struct breakpoint *bp; + long length; + volatile struct gdb_exception except; + struct ui_file *string_file; + struct cleanup *chain; + SCM result; + char *cmdstr; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + bp = self_bp->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_convert_gdb_exception (except); + } + + cmdstr = ui_file_xstrdup (string_file, &length); + make_cleanup (xfree, cmdstr); + //TODO: host charset + result = gdbscm_c_to_scm_string (cmdstr); + do_cleanups (chain); + return result; +} + +/* Scheme function to get the breakpoint type. */ + +static SCM +bpscm_ref_type (SCM self) +{ + breakpoint_smob *self_bp; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + return scm_from_long (self_bp->bp->type); +} + +/* Scheme function to get the visibility of the breakpoint. */ + +static SCM +bpscm_ref_visible (SCM self) +{ + breakpoint_smob *self_bp; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + return scm_from_bool (self_bp->bp->number >= 0); +} + +/* Scheme function to get the breakpoint's number. */ + +static SCM +bpscm_ref_number (SCM self) +{ + breakpoint_smob *self_bp; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + return scm_from_long (self_bp->number); +} + +/* Scheme function to create a new breakpoint. */ + +static SCM +bpscm_make_breakpoint (SCM spec_scm, SCM rest) +{ + static const char * const keywords[] = + { "type", "wp_class", "internal", NULL }; + char *spec; + int type = bp_breakpoint; + int access_type = hw_write; + int internal = 0; + SCM smob; + volatile struct gdb_exception except; + + gdbscm_parse_function_args (FUNC_NAME, keywords, "s#iit", + spec_scm, &spec, rest, + &type, &access_type, &internal); + + smob = make_breakpoint_smob (); + pending_breakpoint_smob = smob; + + TRY_CATCH (except, RETURN_MASK_ALL) + { + struct cleanup *cleanup = make_cleanup (xfree, spec); + + switch (type) + { + case bp_breakpoint: + { + create_breakpoint (target_gdbarch (), + 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); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + { + breakpoint_smob *bp_smob; + + /* Sanity check. */ + ASSERT_VALID_BKPT (smob, bp_smob, FUNC_NAME); + } + return smob; +} + +/* 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 +bpscm_delete_x (SCM self) +{ + breakpoint_smob *self_bp; + volatile struct gdb_exception except; + + ASSERT_VALID_BKPT (self, self_bp, FUNC_NAME); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + delete_breakpoint (self_bp->bp); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + return SCM_UNSPECIFIED; +} + +/* iterate_over_breakpoints function for gdbscm_breakpoints. */ + +static int +build_bp_list (struct breakpoint *b, void *arg) +{ + SCM *list = arg; + SCM *bp = (SCM *) b->scm_bp_object; + + /* Not all breakpoints will have a companion Scheme object. + Only breakpoints that trigger the created_breakpoint observer call + get a companion object (this includes Scheme-created breakpoints). */ + + if (bp != NULL) + *list = scm_cons (*bp, *list); + + return 0; +} + +/* Scheme function to return a list holding 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 (build_bp_list, &list) != NULL) + return SCM_BOOL_F; + + return scm_reverse_x (list, SCM_EOL); +} + +/* Return TRUE if "stop" has been set for this breakpoint. + + This is the script_lang.breakpoint_has_cond "method". */ + +int +gdbscm_breakpoint_has_cond (struct breakpoint *b) +{ + breakpoint_smob *bp_smob; + SCM scm_bp; + + if (b->scm_bp_object == NULL) + return 0; + + bp_smob = b->scm_bp_object; + + return gdbscm_is_procedure (bp_smob->stop); +} + +/* Call the "stop" method (if implemented) in the breakpoint class. + If the 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 script_lang.breakpoint_cond_says_stop "method". */ + +int +gdbscm_breakpoint_cond_says_stop (struct breakpoint *b) +{ + breakpoint_smob *bp_smob; + int stop; + + if (b->scm_bp_object == NULL) + return 0; + + bp_smob = b->scm_bp_object; + + /* FIXME: If there is no "stop" we return true? */ + stop = 1; + + if (gdbscm_is_procedure (bp_smob->stop)) + { + SCM result = gdbscm_safe_call_1 (bp_smob->stop, bp_smob->containing_scm); + + if (gdbscm_is_exception (result)) + { + gdbscm_print_stack (); + gdbscm_print_exception (result); + } + /* If the "stop" function returns False that means + the Scheme breakpoint wants GDB to continue. */ + else if (gdbscm_is_false (result)) + stop = 0; + } + + return stop; +} + +/* Event callback functions. */ + +/* Callback that is used when a breakpoint is created. + This function will use pending_breakpoint_object if it exists, + or create a new Scheme breakpoint object. */ + +static void +breakpoint_created (struct breakpoint *bp) +{ + SCM smob; + breakpoint_smob *bp_smob; + + if (bp->number < 0 && gdbscm_is_false (pending_breakpoint_smob)) + return; + + 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; + + /* pending_breakpoint_smob is non-#f if we get here via Scheme. + Otherwise someone else created the breakpoint (e.g. "b main"). */ + if (! gdbscm_is_false (pending_breakpoint_smob)) + { + smob = pending_breakpoint_smob; + pending_breakpoint_smob = SCM_BOOL_F; + } + else + { + smob = make_breakpoint_smob (); + } + + bp_smob = (breakpoint_smob *) SCM_SMOB_DATA (smob); + bp_smob->number = bp->number; + bp_smob->bp = bp; + bp_smob->containing_scm = smob; + bp_smob->bp->scm_bp_object = bp_smob; + + /* The SCM of this breakpoint is not necessarily in GC-controlled memory, + so we need to protect it from GC until the breakpoint is deleted. */ + scm_gc_protect_object (smob); +} + +/* Callback that is used when a breakpoint is deleted. This will + invalidate the corresponding Scheme object. */ + +static void +breakpoint_deleted (struct breakpoint *b) +{ + int num = b->number; + struct breakpoint *bp; + + /* FIXME: 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_variable breakpoint_variables[] = +{ + { "*init-breakpoint*", SCM_BOOL_F }, + { NULL, SCM_BOOL_F } +}; + +static const scheme_function breakpoint_functions[] = +{ + { "make-breakpoint", 1, 0, 1, bpscm_make_breakpoint }, + { "breakpoint?", 1, 0, 0, gdbscm_breakpoint_p }, + { "breakpoints", 0, 0, 0, gdbscm_breakpoints }, + { "breakpoint-delete!", 1, 0, 0, bpscm_delete_x }, + + { "breakpoint-valid?", 1, 0, 0, bpscm_valid_p }, + { "breakpoint-enabled?", 1, 0, 0, bpscm_enabled_p }, + { "breakpoint-set-enabled!", 2, 0, 0, bpscm_set_enabled_x }, + { "breakpoint-silent?", 1, 0, 0, bpscm_silent_p }, + { "breakpoint-set-silent!", 2, 0, 0, bpscm_set_silent_x }, + { "breakpoint-ref-ignore-count", 1, 0, 0, bpscm_ref_ignore_count }, + { "breakpoint-set-ignore-count", 2, 0, 0, bpscm_set_ignore_count_x }, + { "breakpoint-ref-hit-count", 1, 0, 0, bpscm_ref_hit_count }, + { "breakpoint-set-hit-count", 2, 0, 0, bpscm_set_hit_count_x }, + { "breakpoint-ref-thread", 1, 0, 0, bpscm_ref_thread }, + { "breakpoint-set-thread!", 2, 0, 0, bpscm_set_thread_x }, + { "breakpoint-ref-task", 1, 0, 0, bpscm_ref_task }, + { "breakpoint-set-task!", 2, 0, 0, bpscm_set_task_x }, + { "breakpoint-ref-location", 1, 0, 0, bpscm_ref_location }, + { "breakpoint-ref-expression", 1, 0, 0, bpscm_ref_expression }, + { "breakpoint-ref-condition", 1, 0, 0, bpscm_ref_condition }, + { "breakpoint-set-condition!", 2, 0, 0, bpscm_set_condition_x }, + { "breakpoint-ref-commands", 1, 0, 0, bpscm_ref_commands }, + { "breakpoint-ref-type", 1, 0, 0, bpscm_ref_type }, + { "breakpoint-ref-visible", 1, 0, 0, bpscm_ref_visible }, + { "breakpoint-ref-number", 1, 0, 0, bpscm_ref_number }, + + { NULL, 0, 0, 0, NULL } +}; + +void +gdbscm_initialize_breakpoints (void) +{ + int i; + + breakpoint_smob_tag = + gdbscm_make_smob_type (breakpoint_smob_name, sizeof (breakpoint_smob)); + scm_set_smob_mark (breakpoint_smob_tag, mark_breakpoint_smob); + scm_set_smob_free (breakpoint_smob_tag, free_breakpoint_smob); + scm_set_smob_print (breakpoint_smob_tag, print_breakpoint_smob); + + observer_attach_breakpoint_created (breakpoint_created); + observer_attach_breakpoint_deleted (breakpoint_deleted); + + gdbscm_define_variables (breakpoint_variables, 1); + gdbscm_define_functions (breakpoint_functions, 1); + + /* Add breakpoint types constants. */ + for (i = 0; scmbp_codes[i].name; ++i) + { + scm_c_define (scmbp_codes[i].name, scm_from_int (scmbp_codes[i].code)); + scm_c_export (scmbp_codes[i].name, NULL); + } + + /* Add watchpoint types constants. */ + for (i = 0; scmbp_watch_types[i].name; ++i) + { + scm_c_define (scmbp_watch_types[i].name, + scm_from_int (scmbp_watch_types[i].code)); + scm_c_export (scmbp_watch_types[i].name, NULL); + } +} diff -rpN -U 2 scheme=/scm-exception.c scheme/scm-exception.c --- scheme=/scm-exception.c 1969-12-31 16:00:00.000000000 -0800 +++ scheme/scm-exception.c 2013-09-06 07:52:00.107969300 -0700 @@ -0,0 +1,253 @@ +/* gdb/scheme exception support. + + Copyright (C) 2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#include "defs.h" +#include "gdb_assert.h" +#include "scheme/scheme-internal.h" + +/* SMOB to handle exceptions between gdb and Scheme. */ + +typedef struct +{ + gdb_smob base; + + SCM tag; + 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; + +static SCM +mark_exception_smob (SCM self) +{ + exception_smob *e_smob = (exception_smob *) SCM_SMOB_DATA (self); + + scm_gc_mark (e_smob->tag); + scm_gc_mark (e_smob->args); + /* Do this last. */ + return gdbscm_mark_gsmob (&e_smob->base); +} + +static int +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_display (e_smob->tag, port); + scm_puts (" ", port); + scm_display (e_smob->args, port); + scm_puts (">", port); + + scm_remember_upto_here_1 (self); + + /* Non-zero means success. */ + return 1; +} + +SCM +gdbscm_make_exception (SCM tag, SCM args) +{ + exception_smob *e_smob = (exception_smob *) + scm_gc_malloc (sizeof (exception_smob), exception_smob_name); + SCM smob; + + e_smob->tag = SCM_BOOL_F; + e_smob->args = SCM_BOOL_F; + smob = scm_new_smob (exception_smob_tag, (scm_t_bits) e_smob); + gdbscm_init_gsmob (smob, &e_smob->base, exception_smob_name); + return smob; +} + +int +gdbscm_is_exception (SCM scm) +{ + if (SCM_IMP (scm)) + return 0; + return SCM_TYP16 (scm) == exception_smob_tag; +} + +static SCM +gdbscm_exception_p (SCM scm) +{ + return scm_from_bool (gdbscm_is_exception (scm)); +} + +/* Convert a GDB exception to the appropriate Scheme exception. + This function does not return. */ +// FIXME:wip + +void +gdbscm_convert_gdb_exception (struct gdb_exception exception) +{ + const char *key; + + if (exception.reason == RETURN_QUIT) + key = "interrupt"; + else if (exception.error == MEMORY_ERROR) + key = "memory-error"; + else + key = "gdb-error"; + + scm_error (gdbscm_c_string_to_symbol (key), + "gdbscm_convert_gdb_exception", "~S", + scm_list_1 (gdbscm_c_to_scm_string (exception.message)), + SCM_BOOL_F); +} + +/* Return a string description of exception smob EXCEPTION. */ + +char * +gdbscm_exception_to_string (SCM exception) +{ + return "TODO"; +} + +/* Return non-zero if EXCEPTION is a memory error. */ + +int +gdbscm_exception_matches_memory_error (SCM exception) +{ + return 0; //TODO +} + +void +gdbscm_print_exception (SCM exception) +{ + //TODO +} + +void +gdbscm_print_stack (void) +{ + //TODO +} + +/* Utilities to safely call Scheme code, catching all exceptions. + The result is the result of calling the function, or if an exception + is called then the result is a gdbscm_exception_smob object, which can + be tested for with gdbscm_is_exception_smob. */ + +/* TODO: Use pre-unwind handler when we want to print the stack. */ + +static SCM +safe_call_unwind_handler (void *data, SCM tag, SCM args) +{ + return gdbscm_make_exception (tag, args); +} + +static SCM +safe_call_0_body (void *argsp) +{ + SCM *args = argsp; + + return scm_call_0 (args[0]); +} + +SCM +gdbscm_safe_call_0 (SCM proc) +{ + SCM args[] = { proc }; + + /* Pass SCM_BOOL_T for tag to catch all errors. */ + return scm_c_catch (SCM_BOOL_T, safe_call_0_body, args, + safe_call_unwind_handler, NULL, NULL, NULL); +} + +static SCM +safe_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) +{ + SCM args[] = { proc, arg0 }; + + /* Pass SCM_BOOL_T for tag to catch all errors. */ + return scm_c_catch (SCM_BOOL_T, safe_call_1_body, args, + safe_call_unwind_handler, NULL, NULL, NULL); +} + +static SCM +safe_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) +{ + SCM args[] = { proc, arg0, arg1 }; + + /* Pass SCM_BOOL_T for tag to catch all errors. */ + return scm_c_catch (SCM_BOOL_T, safe_call_2_body, args, + safe_call_unwind_handler, NULL, NULL, NULL); +} + +static SCM +safe_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) +{ + SCM args[] = { proc, arg0, rest }; + + /* Pass SCM_BOOL_T for tag to catch all errors. */ + return scm_c_catch (SCM_BOOL_T, safe_apply_1_body, args, + safe_call_unwind_handler, NULL, NULL, NULL); +} + +static const scheme_variable exception_variables[] = +{ + { "*init-exception*", SCM_BOOL_F }, + { NULL, SCM_BOOL_F } +}; + +static const scheme_function exception_functions[] = +{ + { "make-exception", 2, 0, 0, gdbscm_make_exception }, + { "exception?", 1, 0, 0, gdbscm_exception_p }, + { NULL, 0, 0, 0, NULL } +}; + +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, mark_exception_smob); + scm_set_smob_print (exception_smob_tag, print_exception_smob); + + gdbscm_define_variables (exception_variables, 1); + gdbscm_define_functions (exception_functions, 1); +} diff -rpN -U 2 scheme=/scm-iterator.c scheme/scm-iterator.c --- scheme=/scm-iterator.c 1969-12-31 16:00:00.000000000 -0800 +++ scheme/scm-iterator.c 2013-09-06 07:52:07.570969784 -0700 @@ -0,0 +1,175 @@ +/* Simple iterators for gdb/scheme. + + Copyright (C) 2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#include "defs.h" +#include "scheme/scheme-internal.h" + +const char gdbscm_iterator_smob_name[] = "gdb:iterator"; + +/* The tag Guile knows the iterator smob by. */ +static scm_t_bits iterator_smob_tag; + +static SCM +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); +} + +static int +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 ", gdbscm_iterator_smob_name); + scm_display (i_smob->object, port); + scm_puts (" ", port); + scm_display (i_smob->progress, port); + scm_puts (" ", port); + scm_display (i_smob->next_x, port); + scm_puts (">", port); + + scm_remember_upto_here_1 (self); + + /* Non-zero means success. */ + return 1; +} + +/* TODO: keyword args? */ + +SCM +gdbscm_make_iterator (SCM object, SCM progress, SCM next) +{ + iterator_smob *i_smob = (iterator_smob *) + scm_gc_malloc (sizeof (iterator_smob), gdbscm_iterator_smob_name); + SCM smob; + + SCM_ASSERT_TYPE (gdbscm_is_procedure (next), next, 2, FUNC_NAME, + "procedure"); + + i_smob->object = object; + i_smob->progress = progress; + i_smob->next_x = next; + smob = scm_new_smob (iterator_smob_tag, (scm_t_bits) i_smob); + gdbscm_init_gsmob (smob, &i_smob->base, gdbscm_iterator_smob_name); + return smob; +} + +int +gdbscm_is_iterator (SCM scm) +{ + if (SCM_IMP (scm)) + return 0; + return SCM_TYP16 (scm) == iterator_smob_tag; +} + +static SCM +gdbscm_iterator_p (SCM scm) +{ + return scm_from_bool (gdbscm_is_iterator (scm)); +} + +static void +assert_is_iterator (SCM self, const char *func_name) +{ + SCM_ASSERT_TYPE (gdbscm_is_iterator (self), self, 0, func_name, + gdbscm_iterator_smob_name); +} + +static SCM +gdbscm_iterator_object (SCM self) +{ + iterator_smob *i_smob; + + assert_is_iterator (self, FUNC_NAME); + i_smob = (iterator_smob *) SCM_SMOB_DATA (self); + + return i_smob->object; +} + +static SCM +gdbscm_iterator_ref_progress (SCM self) +{ + iterator_smob *i_smob; + + assert_is_iterator (self, FUNC_NAME); + i_smob = (iterator_smob *) SCM_SMOB_DATA (self); + + return i_smob->progress; +} + +static SCM +gdbscm_iterator_set_progress_x (SCM self, SCM value) +{ + iterator_smob *i_smob; + + assert_is_iterator (self, FUNC_NAME); + i_smob = (iterator_smob *) SCM_SMOB_DATA (self); + + i_smob->progress = value; + return SCM_UNSPECIFIED; +} + +static SCM +gdbscm_iterator_next_x (SCM self) +{ + iterator_smob *i_smob; + + assert_is_iterator (self, FUNC_NAME); + i_smob = (iterator_smob *) SCM_SMOB_DATA (self); + /* We leave type-checking of the procedure to gdbscm_safe_call_1. */ + + return gdbscm_safe_call_1 (i_smob->next_x, self); +} + +/* Initialize the Scheme iterator code. */ + +static const scheme_variable iterator_variables[] = +{ + { "*init-iterator*", SCM_BOOL_F }, + { NULL, SCM_BOOL_F } +}; + +static const scheme_function iterator_functions[] = +{ + { "make-iterator", 2, 0, 0, gdbscm_make_iterator }, + { "iterator?", 1, 0, 0, gdbscm_iterator_p }, + { "iterator-object", 1, 0, 0, gdbscm_iterator_object }, + { "iterator-ref-progress", 1, 0, 0, gdbscm_iterator_ref_progress }, + { "iterator-set-progress!", 2, 0, 0, gdbscm_iterator_set_progress_x }, + { "iterator-next!", 1, 0, 0, gdbscm_iterator_next_x }, + { NULL, 0, 0, 0, NULL } +}; + +void +gdbscm_initialize_iterators (void) +{ + iterator_smob_tag = gdbscm_make_smob_type (gdbscm_iterator_smob_name, + sizeof (iterator_smob)); + scm_set_smob_mark (iterator_smob_tag, mark_iterator_smob); + scm_set_smob_print (iterator_smob_tag, print_iterator_smob); + + gdbscm_define_variables (iterator_variables, 1); + gdbscm_define_functions (iterator_functions, 1); +} diff -rpN -U 2 scheme=/scm-pretty-print.c scheme/scm-pretty-print.c --- scheme=/scm-pretty-print.c 1969-12-31 16:00:00.000000000 -0800 +++ scheme/scm-pretty-print.c 2013-09-06 07:52:13.393970162 -0700 @@ -0,0 +1,905 @@ +/* gdb/scheme pretty-printing. + + Copyright (C) 2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#include "defs.h" +#include "gdb_assert.h" +#include "symtab.h" /* Needed by language.h. */ +#include "language.h" +#include "value.h" +#include "valprint.h" +#include "scheme/scheme-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 + }; + +/* SMOB for pretty-printer matchers. */ + +typedef struct +{ + gdb_smob base; + + SCM name; + SCM enabled; + SCM lookup; + //TODO: subprinters? Or use external class mechanism? +} pretty_printer_matcher_smob; + +/* SMOB for pretty-printers. */ + +typedef struct +{ + gdb_smob base; + + SCM display_hint; + SCM to_string; + SCM children; +} pretty_printer_smob; + +static const char pretty_printer_matcher_smob_name[] = + "gdb:pretty-printer-matcher"; +static const char pretty_printer_smob_name[] = "gdb:pretty-printer"; + +/* The tag Guile knows the pretty-printer smobs by. */ +static scm_t_bits pretty_printer_matcher_smob_tag; +static scm_t_bits pretty_printer_smob_tag; + +/* Global list of pretty-printers. */ +static const char pretty_printer_list_name[] = "*pretty-printers*"; + +/* Pretty-printer matcher smobs. */ + +static SCM +mark_pretty_printer_matcher_smob (SCM self) +{ + pretty_printer_matcher_smob *matcher_smob = + (pretty_printer_matcher_smob *) SCM_SMOB_DATA (self); + + scm_gc_mark (matcher_smob->name); + scm_gc_mark (matcher_smob->enabled); + scm_gc_mark (matcher_smob->lookup); + /* Do this last. */ + return gdbscm_mark_gsmob (&matcher_smob->base); +} + +static int +print_pretty_printer_matcher_smob (SCM self, SCM port, scm_print_state *pstate) +{ + pretty_printer_matcher_smob *matcher_smob = + (pretty_printer_matcher_smob *) SCM_SMOB_DATA (self); + + gdbscm_printf (port, "#<%s ", pretty_printer_matcher_smob_name); + scm_display (matcher_smob->name, port); + scm_puts (">", port); + + scm_remember_upto_here_1 (self); + + /* Non-zero means success. */ + return 1; +} + +// TODO: keyword args? + +static SCM +make_pretty_printer_matcher (SCM name, SCM lookup, SCM enabled) +{ + pretty_printer_matcher_smob *matcher_smob = (pretty_printer_matcher_smob *) + scm_gc_malloc (sizeof (pretty_printer_matcher_smob), + pretty_printer_matcher_smob_name); + SCM smob; + + SCM_ASSERT_TYPE (scm_is_string (name), name, 0, FUNC_NAME, "string"); + SCM_ASSERT_TYPE (gdbscm_is_procedure (lookup), lookup, 1, FUNC_NAME, + "procedure"); + SCM_ASSERT_TYPE (gdbscm_is_bool (enabled), enabled, 2, FUNC_NAME, "boolean"); + + matcher_smob->name = name; + matcher_smob->lookup = lookup; + matcher_smob->enabled = enabled; + smob = scm_new_smob (pretty_printer_matcher_smob_tag, + (scm_t_bits) matcher_smob); + gdbscm_init_gsmob (smob, &matcher_smob->base, + pretty_printer_matcher_smob_name); + return smob; +} + +static int +gdbscm_is_pretty_printer_matcher (SCM scm) +{ + if (SCM_IMP (scm)) + return 0; + return SCM_TYP16 (scm) == pretty_printer_matcher_smob_tag; +} + +static SCM +pretty_printer_matcher_p (SCM scm) +{ + return scm_from_bool (gdbscm_is_pretty_printer_matcher (scm)); +} + +/* The printer printer smob. + These are created when a matcher recognizes a value. */ + +static SCM +mark_pretty_printer_smob (SCM self) +{ + pretty_printer_smob *pp_smob = + (pretty_printer_smob *) SCM_SMOB_DATA (self); + + scm_gc_mark (pp_smob->display_hint); + scm_gc_mark (pp_smob->to_string); + scm_gc_mark (pp_smob->children); + /* Do this last. */ + return gdbscm_mark_gsmob (&pp_smob->base); +} + +static int +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_display (pp_smob->display_hint, port); + scm_puts (" ", port); + scm_display (pp_smob->to_string, port); + scm_puts (" ", port); + scm_display (pp_smob->children, port); + scm_puts (">", port); + + scm_remember_upto_here_1 (self); + + /* Non-zero means success. */ + return 1; +} + +// TODO: keyword args? + +static SCM +make_pretty_printer (SCM display_hint, SCM to_string, SCM children) +{ + pretty_printer_smob *pp_smob = (pretty_printer_smob *) + scm_gc_malloc (sizeof (pretty_printer_smob), + pretty_printer_smob_name); + SCM smob; + + pp_smob->display_hint = display_hint; + pp_smob->to_string = to_string; + pp_smob->children = children; + smob = scm_new_smob (pretty_printer_smob_tag, (scm_t_bits) pp_smob); + gdbscm_init_gsmob (smob, &pp_smob->base, pretty_printer_smob_name); + return smob; +} + +static int +gdbscm_is_pretty_printer (SCM scm) +{ + if (SCM_IMP (scm)) + return 0; + return SCM_TYP16 (scm) == pretty_printer_smob_tag; +} + +static SCM +pretty_printer_p (SCM scm) +{ + return scm_from_bool (gdbscm_is_pretty_printer (scm)); +} + +/* Helper function for find_pretty_printer which iterates over a list, + calls each function and inspects output. This will return a + pretty-printer object if one recognizes VALUE. If no printer is found, + it will return #f. On error, it will return an exception smob. + + Note: This has to be efficient and careful. + We don't want to excessively slow down printing of values, but we can't + prevent any kind of random crud from appearing in the pretty-printer list, + and we can't crash because of it. */ + +static SCM +search_pp_list (SCM list, SCM value) +{ + SCM orig_list = list; + + if (scm_is_null (list)) + return SCM_BOOL_F; + SCM_ASSERT_TYPE (scm_is_pair (list), list, 0, FUNC_NAME, "list"); + + /* TODO: This doesn't handle a loop in the list (which would cause + an infinite loop). Later. */ + + for ( ; scm_is_pair (list); list = scm_cdr (list)) + { + SCM matcher_object = scm_car (list); + SCM printer; + pretty_printer_matcher_smob *matcher_smob; + + if (!gdbscm_is_pretty_printer_matcher (matcher_object)) + { + return gdbscm_make_exception (gdbscm_invalid_type_symbol, + matcher_object); + } + + matcher_smob = + (pretty_printer_matcher_smob *) SCM_SMOB_DATA (matcher_object); + + /* Skip if disabled. */ + if (gdbscm_is_false (matcher_smob->enabled)) + continue; + + if (!gdbscm_is_procedure (matcher_smob->lookup)) + { + return gdbscm_make_exception (gdbscm_invalid_type_symbol, + matcher_smob->lookup); + } + + printer = gdbscm_safe_call_2 (matcher_smob->lookup, matcher_object, + value); + if (!gdbscm_is_false (printer)) + { + if (gdbscm_is_exception (printer)) + return printer; + if (!gdbscm_is_pretty_printer (printer)) + { + return gdbscm_make_exception (gdbscm_invalid_type_symbol, + printer); + } + return printer; + } + } + + SCM_ASSERT_TYPE (scm_is_null (list), orig_list, 0, FUNC_NAME, "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 +find_pretty_printer_from_objfiles (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 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 +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 +find_pretty_printer_from_gdb (SCM value) +{ + SCM pp_list, pp; + + /* Fetch the global pretty printer list. */ + pp_list = scm_c_private_ref (gdbscm_module_name, pretty_printer_list_name); + pp = 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 + function that implements it. On error, an exception smob is returned. */ + +static SCM +find_pretty_printer (SCM value) +{ + SCM function; + + /* Look at the pretty-printer list for each objfile + in the current program-space. */ + function = find_pretty_printer_from_objfiles (value); + if (gdbscm_is_true (function)) + return function; + + /* Look at the pretty-printer list for the current program-space. */ + function = find_pretty_printer_from_progspace (value); + if (gdbscm_is_true (function)) + return function; + + /* Look at the pretty-printer list in the gdb module. */ + function = find_pretty_printer_from_gdb (value); + return function; +} + +/* Pretty-print a single value, via the printer smob PRINTER. + The caller is responsible for ensuring PRINTER is a printer smob. + 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 + gdb a value, *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 +pretty_print_one_value (SCM printer, struct value **out_value) +{ + volatile struct gdb_exception except; + SCM result = SCM_BOOL_F; + + *out_value = NULL; + TRY_CATCH (except, RETURN_MASK_ALL) + { + pretty_printer_smob *pp_smob = + (pretty_printer_smob *) SCM_SMOB_DATA (printer); + + result = gdbscm_safe_call_1 (pp_smob->to_string, printer); + if (gdbscm_is_false (result)) + ; /* Done. */ + else if (scm_is_string (result) + /*TODO: || gdbscm_is_lazy_string (result)*/) + ; /* Done. */ +#if 0 //TODO + else if (gdbscm_is_value (result)) + { + *out_value = gdbscm_convert_value_from_scheme (result); + result = SCM_BOOL_T; + } +#endif + else if (gdbscm_is_exception (result)) + ; /* Done. */ + else + { + /* Invalid result from to-string. */ + result = gdbscm_make_exception (gdbscm_invalid_type_symbol, result); + } + } + + return result; +} + +/* Return the display hint for the object printer, PRINTER. + The caller is responsible for ensuring PRINTER is a printer smob. + Return #f if there is no display_hint method, or if the method did not + return a string. On error, print stack trace and return #f. + On success, return the string in SCM form. */ + +static SCM +get_display_hint (SCM printer) +{ + pretty_printer_smob *pp_smob = + (pretty_printer_smob *) SCM_SMOB_DATA (printer); + SCM hint; + + if (!gdbscm_is_procedure (pp_smob->display_hint)) + return SCM_BOOL_F; + + hint = gdbscm_safe_call_1 (pp_smob->display_hint, printer); + if (scm_is_string (hint)) + return hint; + if (gdbscm_is_exception (hint)) + { + gdbscm_print_stack (); + gdbscm_print_exception (hint); + return SCM_BOOL_F; + } + return SCM_BOOL_F; +} + +/* A wrapper for gdbscm_print_stack that ignores memory errors. */ + +static void +print_stack_unless_memory_error (SCM exception, struct ui_file *stream) +{ + if (gdbscm_exception_matches_memory_error (exception)) + { + char *msg = gdbscm_exception_to_string (exception); + struct cleanup *cleanup = make_cleanup (xfree, msg); + + if (msg == NULL || *msg == '\0') + fprintf_filtered (stream, _("")); + else + fprintf_filtered (stream, _(""), msg); + + do_cleanups (cleanup); + } + else + { + gdbscm_print_stack (); + gdbscm_print_exception (exception); + } +} + +/* Helper for gdbscm_apply_val_pretty_printer which calls to_string and + formats the result. */ + +static enum string_repr_result +print_string_repr (SCM printer, SCM hint, + struct ui_file *stream, int recurse, + const struct value_print_options *options, + const struct language_defn *language, + struct gdbarch *gdbarch) +{ + struct value *replacement = NULL; + SCM scm_str = SCM_BOOL_F; + enum string_repr_result result = STRING_REPR_ERROR; + + scm_str = pretty_print_one_value (printer, &replacement); + if (gdbscm_is_false (scm_str)) + { + result = STRING_REPR_NONE; + } + else if (scm_is_eq (scm_str, 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 (scm_str)) + { + struct cleanup *cleanup = make_cleanup (null_cleanup, NULL); + +#if 0 // TODO + if (gdbscm_is_lazy_string (scm_str)) + { + CORE_ADDR addr; + long length; + struct type *type; + char *encoding = NULL; + struct value_print_options local_opts = *options; + + make_cleanup (free_current_contents, &encoding); + gdbscm_extract_lazy_string (scm_str, &addr, &type, + &length, &encoding); + + local_opts.addressprint = 0; + val_print_string (type, encoding, addr, (int) length, + stream, &local_opts); + result = STRING_REPR_OK; + } + else +#endif + { + size_t length; + SCM exception; + char *string = gdbscm_scm_string_to_target_c_string (scm_str, + &length, + &exception); + + if (string != NULL) + { + struct type *type = builtin_type (gdbarch)->builtin_char; + + make_cleanup (xfree, string); + if (scm_is_string (hint) + && gdbscm_is_true (scm_string_equal_p (hint, + gdbscm_string_string))) + { + LA_PRINT_STRING (stream, type, (gdb_byte *) string, + length, NULL, 0, options); + } + else + fputs_filtered (string, stream); + result = STRING_REPR_OK; + } + else + { + gdbscm_print_exception (exception); + result = STRING_REPR_ERROR; + } + } + + do_cleanups (cleanup); + } + else + { + gdb_assert (gdbscm_is_exception (scm_str)); + print_stack_unless_memory_error (scm_str, stream); + result = STRING_REPR_ERROR; + } + + return result; +} + +/* Print an invalidate type error, and the stack. */ + +static void +print_invalid_type_error (SCM object) +{ + SCM exception = gdbscm_make_exception (gdbscm_invalid_type_symbol, object); + + gdbscm_print_stack (); + gdbscm_print_exception (exception); +} + +/* 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 +print_children (SCM printer, SCM hint, + struct ui_file *stream, int recurse, + const struct value_print_options *options, + const struct language_defn *language, + int printed_nothing) +{ + pretty_printer_smob *pp_smob = + (pretty_printer_smob *) SCM_SMOB_DATA (printer); + iterator_smob *i_smob; + int is_string, is_map, is_array, done_flag, pretty; + unsigned int i; + SCM children, iter, status; + struct cleanup *cleanups; + + if (gdbscm_is_false (pp_smob->children)) + return; + if (!gdbscm_is_procedure (pp_smob->children)) + { + print_invalid_type_error (pp_smob->children); + return; + } + + cleanups = make_cleanup (null_cleanup, NULL); + + /* If we are printing a map or an array, we want some special + formatting. */ + is_string = scm_is_string (hint); + is_map = (is_string + && gdbscm_is_true (scm_string_equal_p (hint, + gdbscm_map_string))); + is_array = (is_string + && gdbscm_is_true (scm_string_equal_p (hint, + gdbscm_array_string))); + + children = gdbscm_safe_call_1 (pp_smob->children, printer); + if (gdbscm_is_exception (children)) + { + print_stack_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 (!gdbscm_is_iterator (children)) + { + print_invalid_type_error (children); + goto done; + } + iter = children; + i_smob = (iterator_smob *) SCM_SMOB_DATA (iter); + + /* 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) + { + SCM scm_name, scm_v; + SCM item = gdbscm_safe_call_1 (i_smob->next_x, iter); + char *name; + struct cleanup *inner_cleanup = make_cleanup (null_cleanup, NULL); + + if (gdbscm_is_exception (item)) + { + print_stack_unless_memory_error (item, stream); + break; + } + else if (gdbscm_is_false (item)) + { + /* Set a flag so we can know whether we printed all the + available elements. */ + done_flag = 1; + break; + } + + if (! scm_is_pair (item)) + { + print_invalid_type_error (item); + continue; + } + scm_name = scm_car (item); + scm_v = scm_cdr (item); + if (!scm_is_string (scm_name)) + { + //TODO: flag error + } + 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 0 //TODO + if (gdbscm_is_lazy_string (scm_v)) + { + CORE_ADDR addr; + struct type *type; + long length; + char *encoding = NULL; + struct value_print_options local_opts = *options; + + make_cleanup (free_current_contents, &encoding); + gdbscm_extract_lazy_string (scm_v, &addr, &type, &length, &encoding); + + local_opts.addressprint = 0; + val_print_string (type, encoding, addr, (int) length, stream, + &local_opts); + } + else +#endif + if (scm_is_string (scm_v)) + { + char *output; + + output = gdbscm_scm_to_host_string (scm_v); + if (!output) + gdbscm_print_stack (); + else + { + fputs_filtered (output, stream); + xfree (output); + } + } +#if 0 //TODO + else + { + struct value *value = convert_value_from_scheme (scm_v); + + if (value == NULL) + { + gdbscm_print_stack (); + error (_("Error while executing Scheme code.")); + } + else + common_val_print (value, stream, recurse + 1, options, language); + } +#endif + + 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 script_lang.apply_val_pretty_printer "method". */ + +int +gdbscm_apply_val_pretty_printer (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; + SCM hint = SCM_BOOL_F; + struct cleanup *cleanups; + int result = 0; + enum string_repr_result print_result; + + /* No pretty-printer support for unavailable values. */ + if (!value_bytes_available (val, embedded_offset, TYPE_LENGTH (type))) + return 0; + + if (!gdb_scheme_initialized) + return 0; + + 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 = gdbscm_value_to_value_object (value); + + /* Find the constructor. */ + printer = find_pretty_printer (val_obj); + + if (gdbscm_is_exception (printer)) + { + exception = printer; + goto done; + } + if (gdbscm_is_false (printer)) + goto done; + if (!gdbscm_is_plain_gsmob (printer)) + { + exception = gdbscm_make_exception (gdbscm_invalid_type_symbol, printer); + goto done; + } + + /* If we are printing a map, we want some special formatting. */ + hint = get_display_hint (printer); + + /* Print the section */ + print_result = print_string_repr (printer, hint, stream, recurse, + options, language, gdbarch); + if (print_result != STRING_REPR_ERROR) + print_children (printer, hint, stream, recurse, options, language, + print_result == STRING_REPR_NONE); + + result = 1; + + done: + if (gdbscm_is_exception (exception)) + print_stack_unless_memory_error (exception, stream); + do_cleanups (cleanups); + return result; +} + +/* Initialize the Scheme pretty-printer code. */ + +static const scheme_variable pretty_printer_variables[] = +{ + { "*init-pretty-printer-matcher*", SCM_BOOL_F }, + { "*init-pretty-printer*", SCM_BOOL_F }, + { NULL, SCM_BOOL_F } +}; + +static const scheme_function pretty_printer_functions[] = +{ + { "make-pretty-printer-matcher", 3, 0, 0, make_pretty_printer_matcher }, + { "pretty-printer-matcher?", 1, 0, 0, pretty_printer_matcher_p }, + { "make-pretty-printer", 2, 0, 0, make_pretty_printer }, + { "pretty-printer?", 1, 0, 0, pretty_printer_p }, + { NULL, 0, 0, 0, NULL } +}; + +void +gdbscm_initialize_pretty_printers (void) +{ + pretty_printer_matcher_smob_tag = + gdbscm_make_smob_type (pretty_printer_matcher_smob_name, + sizeof (pretty_printer_matcher_smob)); + scm_set_smob_mark (pretty_printer_matcher_smob_tag, + mark_pretty_printer_matcher_smob); + scm_set_smob_print (pretty_printer_matcher_smob_tag, + print_pretty_printer_matcher_smob); + + pretty_printer_smob_tag = + gdbscm_make_smob_type (pretty_printer_smob_name, + sizeof (pretty_printer_smob)); + scm_set_smob_mark (pretty_printer_smob_tag, mark_pretty_printer_smob); + scm_set_smob_print (pretty_printer_smob_tag, print_pretty_printer_smob); + + gdbscm_define_variables (pretty_printer_variables, 1); + gdbscm_define_functions (pretty_printer_functions, 1); + + scm_c_define (pretty_printer_list_name, SCM_EOL); +} diff -rpN -U 2 scheme=/scm-smobs.c scheme/scm-smobs.c --- scheme=/scm-smobs.c 1969-12-31 16:00:00.000000000 -0800 +++ scheme/scm-smobs.c 2013-09-06 07:52:21.592970694 -0700 @@ -0,0 +1,282 @@ +/* gdb/scheme smobs (gsmob is pronounced "gee smob") + + Copyright (C) 2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +/* Smobs are Guile's "small object". + They are used to export C structs into 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 adds 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. + + A gsmob consists of two common pieces: vtable, values. + Think of "vtable" as the immutable part of the extended object (e.g., + a vector describing the object) and "values" as the mutable part. + The form of vtable and values is defined by the implementation of the + object API. When a gsmob is constructed we call out to Scheme to + initialize them Afterwards GDB doesn't touch them, except to mark them + when asked by GC. +*/ + +#include "defs.h" +#include "hashtab.h" +#include "gdb_assert.h" +#include "scheme-internal.h" + +/* We need to call this. Undo our hack to prevent others from calling it. */ +#undef scm_make_smob_type + +static const char plain_gsmob_name[] = "gdb:plain-gsmob"; + +static htab_t registered_gsmobs; + +/* The tag Guile knows the plain gsmob by. */ +static scm_t_bits plain_gsmob_tag; + +/* 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 a registered gdb object. */ + +static int +gsmob_p (SCM scm) +{ + void **slot; + + /* This digs into Guile internals a bit. + If this isn't kosher, IWBN if Guile exported what we need. */ + if (SCM_IMP (scm)) + return 0; + slot = htab_find_slot (registered_gsmobs, (void *) SCM_TYP16 (scm), NO_INSERT); + return slot != NULL; +} + +/* Note to self: Leave _gsmob in the name. */ + +int +gdbscm_is_plain_gsmob (SCM scm) +{ + if (SCM_IMP (scm)) + return 0; + return SCM_TYP16 (scm) == plain_gsmob_tag; +} + +/* 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; +} + +/* Call out to Scheme to initialize SMOB. + If the initializer throws an exception print the exception and leave + vtable,values as #f. This shouldn't happen except when there are bugs + in the initializer. */ + +void +gdbscm_init_gsmob (SCM smob, gdb_smob *base, const char *kind) +{ + SCM proc, status; + const char *colon; + char *initer; + + base->kind = kind; + base->vtable = SCM_BOOL_F; + base->values = SCM_BOOL_F; + + /* Remove any leading "gdb:" from kind. */ + colon = strchr (kind, ':'); + if (colon != NULL) + kind = colon + 1; + + initer = xstrprintf ("*init-%s*", kind); + proc = scm_c_public_ref (gdbscm_module_name, initer); + if (gdbscm_is_false (proc)) + return; + if (gdbscm_is_procedure (proc)) + { + fprintf_unfiltered (gdb_stderr, "bad value for Scheme initializer %s", + initer); + } + status = gdbscm_safe_call_1 (proc, smob); + if (gdbscm_is_exception (status)) + { + gdbscm_print_exception (status); + base->vtable = SCM_BOOL_F; + base->values = 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) +{ + scm_gc_mark (base->vtable); + /* Return the last one to mark as an optimization. + The marking infrastructure will mark it for us. */ + return base->values; +} + +/* Plain gsmobs are for objects that don't need any internal storage but + which want to use the gsmob API. We could still create a different smob + for each type, but we avoid this to not push the 256 limit in #smobs. + Such objects can still be distinguish in Scheme via gsmob-kind. */ + +static SCM +mark_plain_gsmob (SCM self) +{ + gdb_smob *g_smob = (gdb_smob *) SCM_SMOB_DATA (self); + + /* Do this last. */ + return gdbscm_mark_gsmob (g_smob); +} + +static int +print_plain_gsmob (SCM self, SCM port, scm_print_state *pstate) +{ + gdb_smob *g_smob = (gdb_smob *) SCM_SMOB_DATA (self); + + gdbscm_printf (port, "#<%s", plain_gsmob_name); + + // TODO: When to display attributes? + + scm_puts (">", port); + + scm_remember_upto_here_1 (self); + + /* Non-zero means success. */ + return 1; +} + +/* Accessors to the vtable/values SCMs. */ + +static void +assert_valid_gsmob (SCM self, const char *func_name) +{ + SCM_ASSERT_TYPE (gsmob_p (self), self, 0, func_name, "gdb-smob"); +} + +static SCM +gsmob_ref_vtable (SCM self) +{ + gdb_smob *base; + + assert_valid_gsmob (self, FUNC_NAME); + base = (gdb_smob *) SCM_SMOB_DATA (self); + return base->vtable; +} + +static SCM +gsmob_set_vtable_x (SCM self, SCM vtable) +{ + gdb_smob *base; + + assert_valid_gsmob (self, FUNC_NAME); + base = (gdb_smob *) SCM_SMOB_DATA (self); + base->vtable = vtable; + return SCM_UNSPECIFIED; +} + +static SCM +gsmob_ref_values (SCM self) +{ + gdb_smob *base; + + assert_valid_gsmob (self, FUNC_NAME); + base = (gdb_smob *) SCM_SMOB_DATA (self); + return base->values; +} + +static SCM +gsmob_set_values_x (SCM self, SCM values) +{ + gdb_smob *base; + + assert_valid_gsmob (self, FUNC_NAME); + base = (gdb_smob *) SCM_SMOB_DATA (self); + base->values = values; + return SCM_UNSPECIFIED; +} + +/* Initialize the Scheme breakpoint code. */ + +static const scheme_function gsmob_functions[] = +{ + { "gsmob-ref-vtable", 1, 0, 0, gsmob_ref_vtable }, + { "gsmob-set-vtable!", 2, 0, 0, gsmob_set_vtable_x }, + { "gsmob-ref-values", 1, 0, 0, gsmob_ref_values }, + { "gsmob-set-values!", 2, 0, 0, gsmob_set_values_x }, + { NULL, 0, 0, 0, NULL } +}; + +void +gdbscm_initialize_smobs (void) +{ + registered_gsmobs = htab_create_alloc (10, + hash_scm_t_bits, eq_scm_t_bits, + NULL, xcalloc, xfree); + + plain_gsmob_tag = gdbscm_make_smob_type (plain_gsmob_name, + sizeof (gdb_smob)); + scm_set_smob_mark (plain_gsmob_tag, mark_plain_gsmob); + scm_set_smob_print (plain_gsmob_tag, print_plain_gsmob); + + gdbscm_define_functions (gsmob_functions, 1); +} diff -rpN -U 2 scheme=/scm-smobs.h scheme/scm-smobs.h --- scheme=/scm-smobs.h 1969-12-31 16:00:00.000000000 -0800 +++ scheme/scm-smobs.h 2013-09-06 07:54:33.286979243 -0700 @@ -0,0 +1,63 @@ +/* scm/gdb smobs (smobs are Guile's "small objects" facility) + + Copyright (C) 2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#ifndef GDB_SCHEME_SMOBS_H +#define GDB_SCHEME_SMOBS_H + +/* All gdb smobs contain this struct as the first member. + It allows for extending them without tying gdb to how they're extended. + + Think of "vtable" as the immutable part of the extended object (e.g., + a vector describing the object) and "values" as the mutable part. + The form of vtable and values is defined by the implementation of the + object API. */ + +typedef struct +{ + /* The kind of object, e.g. "value". + This is assumed to be a literal C string (not malloc'd). */ + const char *kind; + + /* A vtable or description of the object. */ + SCM vtable; + + /* The set of values of the object (e.g. structure members). */ + SCM values; +} gdb_smob; + +/* Return non-zero if SCM is a plain gdb smob. + A plain gsmob is one that doesn't have a specific purpose. + It allows creating an arbitrary number of kinds of objects that use + the same api. */ +int gdbscm_is_plain_gsmob (SCM scm); + +/* Register a smob. Call this instead of scm_make_smob_type. */ +extern scm_t_bits gdbscm_make_smob_type (const char *name, size_t size); + +/* Initialize the Scheme part of a gdb smob. */ +extern void gdbscm_init_gsmob (SCM smob, gdb_smob *base, + const char *kind); + +/* The "mark" function for struct gdb_smob. */ +extern SCM gdbscm_mark_gsmob (gdb_smob *base); + +/* Called early in gdb/scheme initialization. */ +extern void gdbscm_initialize_smobs (void); + +#endif /* GDB_SCHEME_SMOBS_H */ diff -rpN -U 2 scheme=/scm-type-printers.c scheme/scm-type-printers.c --- scheme=/scm-type-printers.c 1969-12-31 16:00:00.000000000 -0800 +++ scheme/scm-type-printers.c 2013-09-06 07:53:36.487975556 -0700 @@ -0,0 +1,42 @@ +/* Type printers for gdb/scheme. + + Copyright (C) 2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#include "defs.h" +#include "gdb_assert.h" +#include "scripting.h" +#include "scheme-internal.h" + +void +gdbscm_start_type_printers (struct slang_type_printers *slang_printers) +{ + //TODO +} + +char * +gdbscm_apply_type_printers (const struct slang_type_printers *slang_printers, + struct type *type) +{ + return NULL; //TODO +} + +void +gdbscm_free_type_printers (struct slang_type_printers *slang_printers) +{ + //TODO +} diff -rpN -U 2 scheme=/scm-type.c scheme/scm-type.c --- scheme=/scm-type.c 1969-12-31 16:00:00.000000000 -0800 +++ scheme/scm-type.c 2013-09-06 07:53:42.109975921 -0700 @@ -0,0 +1,1318 @@ +/* gdb/scheme interface to types. + + Copyright (C) 2008-2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +// TODO: Extract common bits with py-type.c into utilities in core gdb. +// E.g., type comparisons + +#include "defs.h" +#include "value.h" +#include "exceptions.h" +#include "charset.h" +#include "gdbtypes.h" +#include "objfiles.h" +#include "language.h" +#include "vec.h" +#include "bcache.h" +#include "dwarf2loc.h" +#include "typeprint.h" +#include "scheme-internal.h" + +/* A smob containing gdb types. */ + +typedef struct _type_smob +{ + gdb_smob base; + + struct type *type; + + /* If a Type object is associated with an objfile, it is kept on a + doubly-linked list, rooted in the objfile. This lets us copy the + underlying struct type when the objfile is deleted. */ + struct _type_smob *prev; + struct _type_smob *next; +} type_smob; + +/* A field smob. */ + +typedef struct +{ + gdb_smob base; + + /* Backlink to the containing type, and field number. */ + /* FIXME: Do we need some mechanism like what g-breakpoint.c uses to + flag freed types as invalid? */ + SCM type_scm; + int field_num; +} field_smob; + +/* This is used to initialize various gdb.TYPE_ constants. */ + +struct tyscm_code +{ + /* The code. */ + enum type_code code; + /* The name. */ + const char *name; +}; + +static const char type_smob_name[] = "gdb:type"; +static const char field_smob_name[] = "gdb:field"; + +static const char not_composite_error[] = + "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_scm; + +// forward decls +static void tyscm_set_type (type_smob *obj, struct type *type); +static void tyscm_dealloc_type (SCM obj); +static struct type *tyscm_get_composite (struct type *type); + +#define ENTRY(X) { X, #X } + +static const struct tyscm_code tyscm_codes[] = +{ + ENTRY (TYPE_CODE_BITSTRING), + ENTRY (TYPE_CODE_PTR), + ENTRY (TYPE_CODE_ARRAY), + ENTRY (TYPE_CODE_STRUCT), + ENTRY (TYPE_CODE_UNION), + ENTRY (TYPE_CODE_ENUM), + ENTRY (TYPE_CODE_FLAGS), + ENTRY (TYPE_CODE_FUNC), + ENTRY (TYPE_CODE_INT), + ENTRY (TYPE_CODE_FLT), + ENTRY (TYPE_CODE_VOID), + ENTRY (TYPE_CODE_SET), + ENTRY (TYPE_CODE_RANGE), + ENTRY (TYPE_CODE_STRING), + ENTRY (TYPE_CODE_ERROR), + ENTRY (TYPE_CODE_METHOD), + ENTRY (TYPE_CODE_METHODPTR), + ENTRY (TYPE_CODE_MEMBERPTR), + ENTRY (TYPE_CODE_REF), + ENTRY (TYPE_CODE_CHAR), + ENTRY (TYPE_CODE_BOOL), + ENTRY (TYPE_CODE_COMPLEX), + ENTRY (TYPE_CODE_TYPEDEF), + ENTRY (TYPE_CODE_NAMESPACE), + ENTRY (TYPE_CODE_DECFLOAT), + ENTRY (TYPE_CODE_INTERNAL_FUNCTION), + { TYPE_CODE_UNDEF, NULL } +}; + +#undef ENTRY + +/* Type smobs. */ + +static SCM +mark_type_smob (SCM self) +{ + type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (self); + + /* Do this last. */ + return gdbscm_mark_gsmob (&t_smob->base); +} + +static size_t +free_type_smob (SCM self) +{ + tyscm_dealloc_type (self); + return 0; +} + +static int +print_type_smob (SCM self, SCM port, scm_print_state *pstate) +{ + type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (self); + const char *name = type_name_no_tag (t_smob->type); + + gdbscm_printf (port, "#<%s ", type_smob_name); + scm_puts (name ? name : "{unnamed}", port); + scm_puts (">", port); + + scm_remember_upto_here_1 (self); + + /* Non-zero means success. */ + return 1; +} + +static SCM +tyscm_make_type_smob (struct type *type) +{ + type_smob *t_smob = (type_smob *) + scm_gc_malloc (sizeof (type_smob), type_smob_name); + SCM result; + + t_smob->type = type; + /* This fills in next,prev. */ + tyscm_set_type (t_smob, type); + result = scm_new_smob (type_smob_tag, (scm_t_bits) t_smob); + gdbscm_init_gsmob (result, &t_smob->base, type_smob_name); + return result; +} + +int +gdbscm_is_type (SCM self) +{ + if (SCM_IMP (self)) + return 0; + return SCM_TYP16 (self) == type_smob_tag; +} + +static SCM +gdbscm_type_p (SCM self) +{ + return scm_from_bool (gdbscm_is_type (self)); +} + +/* Create a new type smob referring to TYPE. */ + +static SCM +gdbscm_type_to_type_object (struct type *type) +{ + return tyscm_make_type_smob (type); +} + +static const struct objfile_data *tyscm_objfile_data_key; + +static void +save_objfile_types (struct objfile *objfile, void *datum) +{ + type_smob *obj = datum; + htab_t copied_types; + + if (!gdb_scheme_initialized) + return; + + copied_types = create_copied_types_hash (objfile); + + while (obj) + { + type_smob *next = obj->next; + + htab_empty (copied_types); + + obj->type = copy_type_recursive (objfile, obj->type, copied_types); + + obj->next = NULL; + obj->prev = NULL; + + obj = next; + } + + htab_delete (copied_types); +} + +static void +tyscm_set_type (type_smob *obj, struct type *type) +{ + obj->type = type; + obj->prev = NULL; + if (type && TYPE_OBJFILE (type)) + { + struct objfile *objfile = TYPE_OBJFILE (type); + + obj->next = objfile_data (objfile, tyscm_objfile_data_key); + if (obj->next) + obj->next->prev = obj; + set_objfile_data (objfile, tyscm_objfile_data_key, obj); + } + else + obj->next = NULL; +} + +static void +tyscm_dealloc_type (SCM obj) +{ + type_smob *t_smob = (type_smob *) SCM_SMOB_DATA (obj); + + if (t_smob->prev) + t_smob->prev->next = t_smob->next; + else if (t_smob->type && TYPE_OBJFILE (t_smob->type)) + { + /* Must reset head of list. */ + struct objfile *objfile = TYPE_OBJFILE (t_smob->type); + + if (objfile) + set_objfile_data (objfile, tyscm_objfile_data_key, t_smob->next); + } + if (t_smob->next) + t_smob->next->prev = t_smob->prev; +} + +/* Field smobs. */ + +static SCM +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); +} + +static int +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_display (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; +} + +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 (result, &f_smob->base, field_smob_name); + return result; +} + +static int +gdbscm_is_field (SCM self) +{ + if (SCM_IMP (self)) + return 0; + return SCM_TYP16 (self) == field_smob_tag; +} + +static SCM +gdbscm_field_p (SCM self) +{ + return scm_from_bool (gdbscm_is_field (self)); +} + +/* Type smob accessors. */ + +#define ASSERT_GDB_TYPE(func_name, self, t_smob, type) \ + do { \ + assert_is_type (self, func_name); \ + t_smob = (type_smob *) SCM_SMOB_DATA (self); \ + type = t_smob->type; \ + } while (0) + +static void +assert_is_type (SCM self, const char *func_name) +{ + SCM_ASSERT_TYPE (gdbscm_is_type (self), self, 0, func_name, type_smob_name); +} + +/* Return the code for this type. */ + +static SCM +tyscm_type_code (SCM self) +{ + type_smob *t_smob; + struct type *type; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + return scm_from_int (TYPE_CODE (type)); +} + +/* Return a list of all fields. Each field is a gdb:field object. */ + +static SCM +tyscm_type_fields (SCM self) +{ + type_smob *t_smob; + struct type *type; + SCM result; + int i; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + type = tyscm_get_composite (type); + if (type == NULL) + scm_misc_error (FUNC_NAME, not_composite_error, self); + + result = SCM_EOL; + for (i = 0; i < TYPE_NFIELDS (type); ++i) + result = scm_cons (tyscm_make_field_smob (self, i), result); + + return scm_reverse_x (result, SCM_EOL); +} + +/* Return the type's tag, or #f. */ + +static SCM +tyscm_type_tag (SCM self) +{ + type_smob *t_smob; + struct type *type; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + if (!TYPE_TAG_NAME (type)) + return SCM_BOOL_F; + return gdbscm_c_to_scm_string (TYPE_TAG_NAME (type)); +} + +/* Return the size of the type represented by SELF, in bytes. */ + +static SCM +tyscm_type_sizeof (SCM self) +{ + type_smob *t_smob; + struct type *type; + volatile struct gdb_exception except; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + check_typedef (type); + } + /* Ignore exceptions. */ + + return scm_from_long (TYPE_LENGTH (type)); +} + +/* Return the type, stripped of typedefs. */ + +static SCM +tyscm_type_strip_typedefs (SCM self) +{ + type_smob *t_smob; + struct type *type; + volatile struct gdb_exception except; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + type = check_typedef (type); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + return gdbscm_type_to_type_object (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); + } + GDB_SCM_HANDLE_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) +{ + type_smob *t_smob; + struct type *type; + long n1, n2 = 0; + struct type *array = NULL; + volatile struct gdb_exception except; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + gdbscm_parse_function_args (FUNC_NAME, NULL, "l|l", + n1_scm, &n1, n2_scm, &n2); + + if (SCM_UNBNDP (n2_scm)) + { + n2 = n1; + n1 = 0; + } + + if (n2 < n1) + { + scm_misc_error (FUNC_NAME, "array length must not be negative", + scm_cons (scm_from_long (n1), scm_from_long (n2))); + } + + TRY_CATCH (except, RETURN_MASK_ALL) + { + array = lookup_array_range_type (type, n1, n2); + if (is_vector) + make_vector_type (array); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + return gdbscm_type_to_type_object (array); +} + +/* Return an array type. */ + +static SCM +tyscm_type_array (SCM self, SCM n1, SCM n2) +{ + return tyscm_array_1 (self, n1, n2, 0); +} + +/* Return a vector type. */ + +static SCM +tyscm_type_vector (SCM self, SCM n1, SCM n2) +{ + return tyscm_array_1 (self, n1, n2, 1); +} + +/* Return a Type object which represents a pointer to SELF. */ + +static SCM +tyscm_type_pointer (SCM self) +{ + type_smob *t_smob; + struct type *type; + volatile struct gdb_exception except; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + type = lookup_pointer_type (type); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + return gdbscm_type_to_type_object (type); +} + +/* 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 +tyscm_type_range (SCM self) +{ + type_smob *t_smob; + struct type *type; + SCM low_scm, high_scm; + /* Initialize these to appease GCC warnings. */ + LONGEST low = 0, high = 0; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + if (TYPE_CODE (type) != TYPE_CODE_ARRAY + && TYPE_CODE (type) != TYPE_CODE_STRING + && TYPE_CODE (type) != TYPE_CODE_RANGE) + scm_misc_error (FUNC_NAME, "this type does not have a range", self); + + 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 = scm_from_long (low); + high_scm = scm_from_long (high); + + return scm_list_2 (low_scm, high_scm); +} + +/* Return a Type object which represents a reference to SELF. */ + +static SCM +tyscm_type_reference (SCM self) +{ + type_smob *t_smob; + struct type *type; + volatile struct gdb_exception except; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + type = lookup_reference_type (type); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + return gdbscm_type_to_type_object (type); +} + +/* Return a Type object which represents the target type of SELF. */ + +static SCM +tyscm_type_target (SCM self) +{ + type_smob *t_smob; + struct type *type; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + if (!TYPE_TARGET_TYPE (type)) + scm_misc_error (FUNC_NAME, "type does not have a target", self); + + return gdbscm_type_to_type_object (TYPE_TARGET_TYPE (type)); +} + +/* Return a const-qualified type variant. */ + +static SCM +tyscm_type_const (SCM self) +{ + type_smob *t_smob; + struct type *type; + volatile struct gdb_exception except; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + type = make_cv_type (1, 0, type, NULL); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + return gdbscm_type_to_type_object (type); +} + +/* Return a volatile-qualified type variant. */ + +static SCM +tyscm_type_volatile (SCM self) +{ + type_smob *t_smob; + struct type *type; + volatile struct gdb_exception except; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + type = make_cv_type (0, 1, type, NULL); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + return gdbscm_type_to_type_object (type); +} + +/* Return an unqualified type variant. */ + +static SCM +tyscm_type_unqualified (SCM self) +{ + type_smob *t_smob; + struct type *type; + volatile struct gdb_exception except; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + type = make_cv_type (0, 0, type, NULL); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + return gdbscm_type_to_type_object (type); +} + +// TODO: template support elided + +static SCM +tyscm_type_string (SCM self) +{ + type_smob *t_smob; + struct type *type; + volatile struct gdb_exception except; + char *thetype = NULL; + SCM result; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + 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); + + thetype = ui_file_xstrdup (stb, NULL); + do_cleanups (old_chain); + } + if (except.reason < 0) + { + xfree (thetype); + GDB_SCM_HANDLE_EXCEPTION (except); + } + + // TODO: host charset + result = gdbscm_c_to_scm_string (thetype); + xfree (thetype); + + return result; +} + +/* Return number of fields. */ + +static SCM +tyscm_type_length (SCM self) +{ + type_smob *t_smob; + struct type *type; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + type = tyscm_get_composite (type); + if (type == NULL) + scm_misc_error (FUNC_NAME, not_composite_error, self); + + return scm_from_long (TYPE_NFIELDS (type)); +} + +/* Return a gdb:field object for the field named by the argument. */ + +static SCM +tyscm_type_ref_field (SCM self, SCM field_scm) +{ + type_smob *t_smob; + struct type *type; + char *field; + int i; + struct cleanup *cleanups; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, 1, FUNC_NAME, + "string"); + + field = gdbscm_scm_to_c_string (field_scm); + cleanups = make_cleanup (xfree, field); + + /* 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) + scm_misc_error (FUNC_NAME, not_composite_error, self); + + 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)) + return tyscm_make_field_smob (self, i); + } + + scm_misc_error (FUNC_NAME, "unknown field", field_scm); +} + +/* Return boolean indicating if type SELF has FIELD_SCM (a string). */ + +static SCM +tyscm_type_has_field_p (SCM self, SCM field_scm) +{ + type_smob *t_smob; + struct type *type; + char *field; + int i; + struct cleanup *cleanups; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + SCM_ASSERT_TYPE (scm_is_string (field_scm), field_scm, 1, FUNC_NAME, + "string"); + + field = gdbscm_scm_to_c_string (field_scm); + cleanups = make_cleanup (xfree, field); + + /* 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) + scm_misc_error (FUNC_NAME, not_composite_error, self); + + 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)) + return SCM_BOOL_T; + } + return SCM_BOOL_F; +} + +/* Make a field iterator object. */ + +static SCM +tyscm_make_field_iter (SCM self) +{ + type_smob *t_smob; + struct type *type; + + ASSERT_GDB_TYPE (FUNC_NAME, self, t_smob, type); + + /* Check that "self" is a structure or union type. */ + SCM_ASSERT_TYPE (tyscm_get_composite (t_smob->type) != NULL, + self, 0, FUNC_NAME, "composite type"); + + return gdbscm_make_iterator (self, scm_from_int (0), tyscm_next_field_scm); +} + +/* Return the next field in the iteration through the list of fields of the + type. SELF is a gdb:iterator smob created by tyscm_make_field_iter. */ + +static SCM +tyscm_next_field (SCM self) +{ + iterator_smob *iter_smob; + type_smob *t_smob; + struct type *type; + SCM result; + int field; + + SCM_ASSERT_TYPE (gdbscm_is_iterator (self), self, 0, FUNC_NAME, + gdbscm_iterator_smob_name); + iter_smob = (iterator_smob *) SCM_SMOB_DATA (self); + + SCM_ASSERT_TYPE (gdbscm_is_type (iter_smob->object), iter_smob->object, + 0, FUNC_NAME, type_smob_name); + t_smob = (type_smob *) SCM_SMOB_DATA (iter_smob->object); + type = t_smob->type; + + SCM_ASSERT_TYPE (scm_is_signed_integer (iter_smob->progress, + 0, TYPE_NFIELDS (type)), + iter_smob->progress, 0, FUNC_NAME, "integer"); + field = scm_to_int (iter_smob->progress); + + if (field < TYPE_NFIELDS (type)) + { + result = tyscm_make_field_smob (iter_smob->object, field); + iter_smob->progress = scm_from_int (field + 1); + return result; + } + + return SCM_BOOL_F; +} + +/* Field smob accessors. */ + +#define ASSERT_GDB_FIELD(func_name, self, f_smob, field) \ + do { \ + type_smob *t_smob; \ + assert_is_field (self, func_name); \ + f_smob = (field_smob *) SCM_SMOB_DATA (self); \ + assert_is_type (f_smob->type_scm, func_name); \ + t_smob = (type_smob *) SCM_SMOB_DATA (f_smob->type_scm); \ + field = &TYPE_FIELD (t_smob->type, f_smob->field_num); \ + } while (0) + +#define ASSERT_GDB_FIELD_WITH_TYPE(func_name, self, f_smob, field, t_smob) \ + do { \ + assert_is_field (self, func_name); \ + f_smob = (field_smob *) SCM_SMOB_DATA (self); \ + assert_is_type (f_smob->type_scm, func_name); \ + t_smob = (type_smob *) SCM_SMOB_DATA (f_smob->type_scm); \ + field = &TYPE_FIELD (t_smob->type, f_smob->field_num); \ + } while (0) + +static void +assert_is_field (SCM self, const char *func_name) +{ + SCM_ASSERT_TYPE (gdbscm_is_field (self), self, 0, func_name, + field_smob_name); +} + +/* Return the name of this field. */ + +static SCM +tyscm_field_name (SCM self) +{ + field_smob *f_smob; + struct field *field; + + ASSERT_GDB_FIELD (FUNC_NAME, self, f_smob, field); + + if (FIELD_NAME (*field)) + return gdbscm_c_to_scm_string (FIELD_NAME (*field)); + return SCM_BOOL_F; +} + +static SCM +tyscm_field_type (SCM self) +{ + field_smob *f_smob; + struct field *field; + + ASSERT_GDB_FIELD (FUNC_NAME, self, f_smob, field); + + /* A field can have a NULL type in some situations. */ + if (FIELD_TYPE (*field)) + return gdbscm_type_to_type_object (FIELD_TYPE (*field)); + return SCM_BOOL_F; +} + +static SCM +tyscm_field_enumval (SCM self) +{ + type_smob *t_smob; + field_smob *f_smob; + struct field *field; + + ASSERT_GDB_FIELD_WITH_TYPE (FUNC_NAME, self, f_smob, field, t_smob); + SCM_ASSERT_TYPE (TYPE_CODE (t_smob->type) == TYPE_CODE_ENUM, + self, 0, FUNC_NAME, "enum type"); + + return scm_from_long (FIELD_ENUMVAL (*field)); +} + +static SCM +tyscm_field_bitpos (SCM self) +{ + type_smob *t_smob; + field_smob *f_smob; + struct field *field; + + ASSERT_GDB_FIELD_WITH_TYPE (FUNC_NAME, self, f_smob, field, t_smob); + SCM_ASSERT_TYPE (TYPE_CODE (t_smob->type) != TYPE_CODE_ENUM, + self, 0, FUNC_NAME, "non-enum type"); + + return scm_from_long (FIELD_BITPOS (*field)); +} + +static SCM +tyscm_field_bitsize (SCM self) +{ + field_smob *f_smob; + struct field *field; + + ASSERT_GDB_FIELD (FUNC_NAME, self, f_smob, field); + + return scm_from_long (FIELD_BITPOS (*field)); +} + +static SCM +tyscm_field_artificial_p (SCM self) +{ + field_smob *f_smob; + struct field *field; + + ASSERT_GDB_FIELD (FUNC_NAME, self, f_smob, field); + + return scm_from_bool (FIELD_ARTIFICIAL (*field)); +} + +static SCM +tyscm_field_baseclass_p (SCM self) +{ + type_smob *t_smob; + field_smob *f_smob; + struct field *field; + + ASSERT_GDB_FIELD_WITH_TYPE (FUNC_NAME, self, f_smob, field, t_smob); + + if (TYPE_CODE (t_smob->type) == TYPE_CODE_CLASS) + { + return scm_from_bool (f_smob->field_num + < TYPE_N_BASECLASSES (t_smob->type)); + } + return SCM_BOOL_F; +} + +// FIXME: Most of this can be moved to gdb core and shared with python. */ + +/* An entry in the type-equality bcache. */ + +typedef struct type_equality_entry +{ + struct type *type1, *type2; +} type_equality_entry_d; + +DEF_VEC_O (type_equality_entry_d); + +/* A helper function to compare two strings. Returns 1 if they are + the same, 0 otherwise. Handles NULLs properly. */ + +static int +compare_maybe_null_strings (const char *s, const char *t) +{ + if (s == NULL && t != NULL) + return 0; + else if (s != NULL && t == NULL) + return 0; + else if (s == NULL && t== NULL) + return 1; + return strcmp (s, t) == 0; +} + +/* A helper function for tyscm_richcompare that checks two types for + "deep" equality. Returns non-zero if the types are considered the + same, zero otherwise. */ + +static int +check_types_equal (struct type *type1, struct type *type2, + VEC (type_equality_entry_d) **worklist) +{ + CHECK_TYPEDEF (type1); + CHECK_TYPEDEF (type2); + + if (type1 == type2) + return 1; + + if (TYPE_CODE (type1) != TYPE_CODE (type2) + || TYPE_LENGTH (type1) != TYPE_LENGTH (type2) + || TYPE_UNSIGNED (type1) != TYPE_UNSIGNED (type2) + || TYPE_NOSIGN (type1) != TYPE_NOSIGN (type2) + || TYPE_VARARGS (type1) != TYPE_VARARGS (type2) + || TYPE_VECTOR (type1) != TYPE_VECTOR (type2) + || TYPE_NOTTEXT (type1) != TYPE_NOTTEXT (type2) + || TYPE_INSTANCE_FLAGS (type1) != TYPE_INSTANCE_FLAGS (type2) + || TYPE_NFIELDS (type1) != TYPE_NFIELDS (type2)) + return 0; + + if (!compare_maybe_null_strings (TYPE_TAG_NAME (type1), + TYPE_TAG_NAME (type2))) + return 0; + if (!compare_maybe_null_strings (TYPE_NAME (type1), TYPE_NAME (type2))) + return 0; + + if (TYPE_CODE (type1) == TYPE_CODE_RANGE) + { + if (memcmp (TYPE_RANGE_DATA (type1), TYPE_RANGE_DATA (type2), + sizeof (*TYPE_RANGE_DATA (type1))) != 0) + return 0; + } + else + { + int i; + + for (i = 0; i < TYPE_NFIELDS (type1); ++i) + { + const struct field *field1 = &TYPE_FIELD (type1, i); + const struct field *field2 = &TYPE_FIELD (type2, i); + struct type_equality_entry entry; + + if (FIELD_ARTIFICIAL (*field1) != FIELD_ARTIFICIAL (*field2) + || FIELD_BITSIZE (*field1) != FIELD_BITSIZE (*field2) + || FIELD_LOC_KIND (*field1) != FIELD_LOC_KIND (*field2)) + return 0; + if (!compare_maybe_null_strings (FIELD_NAME (*field1), + FIELD_NAME (*field2))) + return 0; + switch (FIELD_LOC_KIND (*field1)) + { + case FIELD_LOC_KIND_BITPOS: + if (FIELD_BITPOS (*field1) != FIELD_BITPOS (*field2)) + return 0; + break; + case FIELD_LOC_KIND_ENUMVAL: + if (FIELD_ENUMVAL (*field1) != FIELD_ENUMVAL (*field2)) + return 0; + break; + case FIELD_LOC_KIND_PHYSADDR: + if (FIELD_STATIC_PHYSADDR (*field1) + != FIELD_STATIC_PHYSADDR (*field2)) + return 0; + break; + case FIELD_LOC_KIND_PHYSNAME: + if (!compare_maybe_null_strings (FIELD_STATIC_PHYSNAME (*field1), + FIELD_STATIC_PHYSNAME (*field2))) + return 0; + break; + case FIELD_LOC_KIND_DWARF_BLOCK: + { + struct dwarf2_locexpr_baton *block1, *block2; + + block1 = FIELD_DWARF_BLOCK (*field1); + block2 = FIELD_DWARF_BLOCK (*field2); + if (block1->per_cu != block2->per_cu + || block1->size != block2->size + || memcmp (block1->data, block2->data, block1->size) != 0) + return 0; + } + break; + default: + internal_error (__FILE__, __LINE__, _("Unsupported field kind " + "%d by check_types_equal"), + FIELD_LOC_KIND (*field1)); + } + + entry.type1 = FIELD_TYPE (*field1); + entry.type2 = FIELD_TYPE (*field2); + VEC_safe_push (type_equality_entry_d, *worklist, &entry); + } + } + + if (TYPE_TARGET_TYPE (type1) != NULL) + { + struct type_equality_entry entry; + + if (TYPE_TARGET_TYPE (type2) == NULL) + return 0; + + entry.type1 = TYPE_TARGET_TYPE (type1); + entry.type2 = TYPE_TARGET_TYPE (type2); + VEC_safe_push (type_equality_entry_d, *worklist, &entry); + } + else if (TYPE_TARGET_TYPE (type2) != NULL) + return 0; + + return 1; +} + +/* Check types on a worklist for equality. Returns zero if any pair + is not equal, non-zero if they are all considered equal. */ + +static int +check_types_worklist (VEC (type_equality_entry_d) **worklist, + struct bcache *cache) +{ + while (!VEC_empty (type_equality_entry_d, *worklist)) + { + struct type_equality_entry entry; + int added; + + entry = *VEC_last (type_equality_entry_d, *worklist); + VEC_pop (type_equality_entry_d, *worklist); + + /* If the type pair has already been visited, we know it is + ok. */ + bcache_full (&entry, sizeof (entry), cache, &added); + if (!added) + continue; + + if (check_types_equal (entry.type1, entry.type2, worklist) == 0) + return 0; + } + + return 1; +} + +/* equal? for types. */ + +static SCM +tyscm_type_equal_p (SCM type1_scm, SCM type2_scm) +{ + type_smob *type1_smob, *type2_smob; + struct type *type1, *type2; + volatile struct gdb_exception except; + int result = 0; + + SCM_ASSERT_TYPE (gdbscm_is_type (type1_scm), type1_scm, 0, FUNC_NAME, + type_smob_name); + SCM_ASSERT_TYPE (gdbscm_is_type (type2_scm), type2_scm, 1, 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; + + if (type1 == type2) + result = 1; + else + { + struct bcache *cache; + VEC (type_equality_entry_d) *worklist = NULL; + struct type_equality_entry entry; + + cache = bcache_xmalloc (NULL, NULL); + + entry.type1 = type1; + entry.type2 = type2; + VEC_safe_push (type_equality_entry_d, worklist, &entry); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + result = check_types_worklist (&worklist, cache); + } + /* check_types_worklist calls several nested helper functions, + some of which can raise a GDB Exception, so we just check + and convert here. If there is a GDB exception, a comparison + is not capable (or trusted), so exit. */ + bcache_xfree (cache); + VEC_free (type_equality_entry_d, worklist); + GDB_SCM_HANDLE_EXCEPTION (except); + } + + return scm_from_bool (result); +} + +/* Implementation of gdb:lookup-type. */ + +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, target_gdbarch (), + type_name, block, 0); + } + if (except.reason < 0) + return NULL; + + return type; +} + +// TODO: legacy template support left out until needed + +// TODO: support for looking up type in block + +static SCM +gdbscm_lookup_type (SCM name_scm) +{ + const char *name; + struct type *type; + + gdbscm_parse_function_args (FUNC_NAME, NULL, "s", name_scm, &name); + + type = tyscm_lookup_typename (name, NULL); + if (type) + return gdbscm_type_to_type_object (type); + return SCM_BOOL_F; +} + +/* Initialize the Scheme type code. */ + +static const scheme_variable type_variables[] = +{ + { "*init-type*", SCM_BOOL_F }, + { "*init-field*", SCM_BOOL_F }, + { NULL, SCM_BOOL_F } +}; + +static const scheme_function type_functions[] = +{ + { "type?", 1, 0, 0, gdbscm_type_p }, + { "lookup-type", 1, 0, 0, gdbscm_lookup_type }, + + { "type-code", 1, 0, 0, tyscm_type_code }, + { "type-fields", 1, 0, 0, tyscm_type_fields }, + { "type-tag", 1, 0, 0, tyscm_type_tag }, + { "type-sizeof", 1, 0, 0, tyscm_type_sizeof }, + { "type-strip-typedefs", 1, 0, 0, tyscm_type_strip_typedefs }, + { "type-array", 2, 1, 0, tyscm_type_array }, + { "type-vector", 2, 1, 0, tyscm_type_vector }, + { "type-pointer", 1, 0, 0, tyscm_type_pointer }, + { "type-range", 1, 0, 0, tyscm_type_range }, + { "type-reference", 1, 0, 0, tyscm_type_reference }, + { "type-target", 1, 0, 0, tyscm_type_target }, + { "type-const", 1, 0, 0, tyscm_type_const }, + { "type-volatile", 1, 0, 0, tyscm_type_volatile }, + { "type-unqualified", 1, 0, 0, tyscm_type_unqualified }, + { "type-string", 1, 0, 0, tyscm_type_string }, + { "type-equal?", 2, 0, 0, tyscm_type_equal_p }, + + { "type-length", 1, 0, 0, tyscm_type_length }, + { "type-ref-field", 2, 0, 0, tyscm_type_ref_field }, + { "type-has-field?", 2, 0, 0, tyscm_type_has_field_p }, + + { "field?", 1, 0, 0, gdbscm_field_p }, + { "make-field-iter", 1, 0, 0, tyscm_make_field_iter }, + + { "field-name", 1, 0, 0, tyscm_field_name }, + { "field-type", 1, 0, 0, tyscm_field_type }, + { "field-enumval", 1, 0, 0, tyscm_field_enumval }, + { "field-bitpos", 1, 0, 0, tyscm_field_bitpos }, + { "field-bitsize", 1, 0, 0, tyscm_field_bitsize }, + { "field-artificial?", 1, 0, 0, tyscm_field_artificial_p }, + { "field-baseclass?", 1, 0, 0, tyscm_field_baseclass_p }, + + { NULL, 0, 0, 0, NULL } +}; + +void +gdbscm_initialize_types (void) +{ + int i; + + tyscm_objfile_data_key + = register_objfile_data_with_cleanup (save_objfile_types, NULL); + + for (i = 0; tyscm_codes[i].name; ++i) + { + scm_c_define (tyscm_codes[i].name, scm_from_int (tyscm_codes[i].code)); + scm_c_export (tyscm_codes[i].name, NULL); + } + + type_smob_tag = gdbscm_make_smob_type (type_smob_name, + sizeof (type_smob)); + scm_set_smob_mark (type_smob_tag, mark_type_smob); + scm_set_smob_free (type_smob_tag, free_type_smob); + scm_set_smob_print (type_smob_tag, print_type_smob); + + field_smob_tag = gdbscm_make_smob_type (field_smob_name, + sizeof (field_smob)); + scm_set_smob_mark (field_smob_tag, mark_field_smob); + scm_set_smob_print (field_smob_tag, print_field_smob); + + gdbscm_define_variables (type_variables, 1); + gdbscm_define_functions (type_functions, 1); + + tyscm_next_field_scm = + scm_c_define_gsubr ("%next-field", 1, 0, 0, tyscm_next_field); +} diff -rpN -U 2 scheme=/scm-utils.c scheme/scm-utils.c --- scheme=/scm-utils.c 1969-12-31 16:00:00.000000000 -0800 +++ scheme/scm-utils.c 2013-09-06 07:53:49.741976417 -0700 @@ -0,0 +1,389 @@ +/* General utility routines for gdb/scheme code. + + Copyright (C) 2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#include "defs.h" +#include +#include "gdb_assert.h" +#include "scheme-internal.h" + +/* 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 print an SCM object. */ + +void +gdbscm_display (SCM obj) +{ + SCM port = scm_current_output_port (); + + scm_display (obj, port); + scm_newline (port); +} + +/* Subroutine of gdbscm_parse_function_args to simplify it. + Return the number of keyword arguments. */ + +static int +count_keywords (const char * const * keywords) +{ + int i; + + if (keywords == NULL) + return 0; + for (i = 0; keywords[i] != NULL; ++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': + 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 scheme argument format character"); + } + } + + return dot_seen; +} + +/* 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. */ + +static void +extract_arg (char format_char, SCM arg, void *argp, + const char *function_name, int position) +{ + switch (format_char) + { + case 's': + { + char **arg_ptr = argp; + + SCM_ASSERT_TYPE (gdbscm_is_true (scm_string_p (arg)), arg, position, + function_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. */ + SCM_ASSERT_TYPE (gdbscm_is_bool (arg), arg, position, function_name, + "boolean"); + *arg_ptr = gdbscm_is_true (arg); + break; + } + case 'l': + { + long *arg_ptr = argp; + + SCM_ASSERT_TYPE (scm_is_signed_integer (arg, LONG_MIN, LONG_MAX), + arg, position, function_name, "long"); + *arg_ptr = scm_to_long (arg); + break; + } + default: + gdb_assert_not_reached ("invalid scheme argument format character"); + } +} + +/* 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 char * const * keyword_list, SCM keyword) +{ + return -1; //TODO +} + +/* 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. + + KEYWORDS may be NULL if there are no keywords. + + FORMAT: + s - string -> char *, malloc'd + t - boolean (gdb uses "t", for biT?) -> int + l - long + | - 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". + + 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 *function_name, + const char * const *keywords, + const char *format, ...) +{ + va_list args; + const char *p; + int i, have_rest, num_keywords, length, position; + int have_optional = 0; + SCM rest = SCM_EOL; + + have_rest = validate_arg_format (format); + num_keywords = count_keywords (keywords); + + va_start (args, format); + + p = format; + position = 0; + + /* Process required, optional arguments. */ + + while (*p && *p != '#' && *p != '.') + { + SCM arg; + void *argptr; + + if (*p == '|') + { + have_optional = 1; + ++p; + continue; + } + + arg = va_arg (args, SCM); + if (!have_optional || !SCM_UNBNDP (arg)) + { + argptr = va_arg (args, void *); + extract_arg (*p, arg, argptr, function_name, position); + } + ++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) + scm_misc_error (function_name, "unrecognized keyword", keyword); + if (!scm_is_pair (scm_cdr (rest))) + { + scm_misc_error (function_name, + "missing value for keyword argument", + keyword); + } + keyword_args[i] = scm_cadr (rest); + keyword_positions[i] = position + 1; + rest = scm_cddr (rest); + position += 2; + } + + for (i = 0; i < num_keywords; ++i) + { + void *argptr = va_arg (args, void *); + SCM arg = keyword_args[i]; + + /* Maybe not kosher. */ + if (! scm_is_eq (arg, SCM_UNSPECIFIED)) + { + extract_arg (p[i], arg, argptr, function_name, + keyword_positions[i]); + } + } + } + + /* 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)) + { + /* FIXME: Perhaps this should call scm_wrong_num_args. */ + scm_misc_error (function_name, "too many arguments", rest); + } + } + + va_end (args); +} + +/* Convert a C (utf8) string to an SCM string. */ + +SCM +gdbscm_c_to_scm_string (const char *string) +{ + return scm_from_utf8_string (string); +} + +/* Convert an SCM string to a C (utf8) string. + Space for the result is allocated with malloc, caller must free. */ + +char * +gdbscm_scm_to_c_string (SCM string) +{ + /* TODO: deal with guile memory of intermediate result */ + /* TODO: charsets */ + return xstrdup (scm_to_utf8_string (string)); +} + +/* Return an SCM symbol for STRING. */ + +SCM +gdbscm_c_string_to_symbol (const char *symbol) +{ + return scm_from_utf8_symbol (symbol); +} + +/* FIXME:wip */ + +char * +gdbscm_scm_to_host_string (SCM string) +{ + return gdbscm_scm_to_c_string (string); +} + +/* FIXME:wip */ + +SCM +gdbscm_scm_string_to_target_scm_string (SCM string) +{ + return string; +} + +/* Result is stored in a malloc'd buffer. */ +//FIXME:wip + +char * +gdbscm_scm_string_to_target_c_string (SCM string, size_t *length, + SCM *exception) +{ + char *result = scm_to_utf8_stringn (string, length); + + *exception = SCM_BOOL_F; + return result; +} + +int +gdbscm_is_procedure (SCM proc) +{ + return gdbscm_is_true (scm_procedure_p (proc)); +} diff -rpN -U 2 scheme=/scm-value.c scheme/scm-value.c --- scheme=/scm-value.c 1969-12-31 16:00:00.000000000 -0800 +++ scheme/scm-value.c 2013-09-06 07:53:54.884976751 -0700 @@ -0,0 +1,237 @@ +/* gdb/scheme interface to values. + + Copyright (C) 2013 Free Software Foundation, Inc. + + This file is part of GDB. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + +#include "defs.h" +#include "gdb_assert.h" +#include "symtab.h" /* Needed by language.h. */ +#include "language.h" +#include "value.h" +#include "valprint.h" +#include "scheme-internal.h" + +/* SMOB to expose a gdb value to Scheme. */ + +typedef struct _value_smob +{ + /* This always appears first. */ + gdb_smob base; + + struct _value_smob *next; + struct _value_smob *prev; + struct value *value; +} 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; + +/* Iterate over all the Value objects, calling preserve_one_value on each. + This is the script_lang.preserve_values "method". */ + +void +gdbscm_preserve_values (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 +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 +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; +} + +static SCM +mark_value_smob (SCM self) +{ + value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self); + + /* Do this last. */ + return gdbscm_mark_gsmob (&v_smob->base); +} + +static size_t +free_value_smob (SCM self) +{ + value_smob *v_smob = (value_smob *) SCM_SMOB_DATA (self); + + forget_value_smob (v_smob); + value_free (v_smob->value); + + return 0; +} + +static int +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; + + gdbscm_printf (port, "#<%s ", value_smob_name); + + 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 (v_smob->value, stb, 0, &opts, current_language); + s = ui_file_xstrdup (stb, NULL); + + do_cleanups (old_chain); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + if (s != NULL) + { + scm_puts (s, port); + xfree (s); + } + + // TODO: When to display attributes? + + scm_puts (">", port); + + scm_remember_upto_here_1 (self); + + /* Non-zero means success. */ + return 1; +} + +static SCM +make_value_smob (struct value *val) +{ + value_smob *v_smob = (value_smob *) + scm_gc_malloc (sizeof (value_smob), value_smob_name); + SCM smob; + + v_smob->value = val; + /* This fills in next,prev. */ + remember_scheme_value (v_smob); + smob = scm_new_smob (value_smob_tag, (scm_t_bits) v_smob); + gdbscm_init_gsmob (smob, &v_smob->base, value_smob_name); + + return smob; +} + +/* Returns an object for a value which is released from the all_values chain, + so its lifetime is not bound to the execution of a command. */ + +SCM +gdbscm_value_to_value_object (struct value *val) +{ + return make_value_smob (val); +} + +int +gdbscm_is_value (SCM scm) +{ + if (SCM_IMP (scm)) + return 0; + return SCM_TYP16 (scm) == value_smob_tag; +} + +static SCM +value_p (SCM scm) +{ + return scm_from_bool (gdbscm_is_value (scm)); +} + +/* Parse a string and evaluate it as an expression. */ + +static SCM +parse_and_eval_from_scheme (SCM expr_scm) +{ + const char *expr_str; + struct value *result = NULL; + volatile struct gdb_exception except; + + gdbscm_parse_function_args (FUNC_NAME, NULL, "s", expr_scm, &expr_str); + + TRY_CATCH (except, RETURN_MASK_ALL) + { + result = parse_and_eval (expr_str); + } + GDB_SCM_HANDLE_EXCEPTION (except); + + return gdbscm_value_to_value_object (result); +} + +/* Initialize the Scheme breakpoint code. */ + +static const scheme_variable value_variables[] = +{ + { "*init-value*", SCM_BOOL_F }, + { NULL, SCM_BOOL_F } +}; + +static const scheme_function value_functions[] = +{ + { "value?", 1, 0, 0, value_p }, + { "parse-and-eval", 1, 0, 0, parse_and_eval_from_scheme }, + { NULL, 0, 0, 0, NULL } +}; + +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, mark_value_smob); + scm_set_smob_free (value_smob_tag, free_value_smob); + scm_set_smob_print (value_smob_tag, print_value_smob); + + gdbscm_define_variables (value_variables, 1); + gdbscm_define_functions (value_functions, 1); +}