* beginnings of Guile support
@ 2013-09-06 15:35 Doug Evans
2013-09-06 16:27 ` Phil Muldoon
2013-09-09 21:09 ` Tom Tromey
0 siblings, 2 replies; 5+ messages in thread
From: Doug Evans @ 2013-09-06 15:35 UTC (permalink / raw)
To: gdb-patches
[-- Attachment #1: Type: text/plain, Size: 346 bytes --]
Hi.
As a personal project, I'm adding scheme scripting to gdb.
This patch is very preliminary (no docs, etc. etc. etc.), but I want
to give people a heads up.
To try to plug scheme in cleanly I've created scripting.[ch] as the
interface between gdb and python/scheme. It's not complete, not least
of which is varobj.c, but it feels reasonable.
[-- Attachment #2: scheme.patch.txt --]
[-- Type: text/plain, Size: 246308 bytes --]
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/<guile-config-program>)]),
+ [], [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 <http://www.gnu.org/licenses/>. */
+
+/* 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);
+ }
+}
+\f
+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);
+}
+\f
+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);
+ }
+}
+\f
+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;
+}
+\f
+/* ^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
+}
+\f
+/* 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 <http://www.gnu.org/licenses/>. */
+
+#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 <ctype.h>
#include <sys/time.h>
@@ -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)
\f
-/* 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;
-
+\f
+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);
+\f
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 */
\f
@@ -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;
+}
+
\f
#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 <http://www.gnu.org/licenses/>.
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 <http://www.gnu.org/licenses/>. */
+
+#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);
+\f
+/* 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);
+\f
+/* 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);
+\f
+/* 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);
+\f
+/* 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 <http://www.gnu.org/licenses/>. */
+
+/* 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 <nothing>
+ - i18n
+*/
+
+/* Implementation notes:
+ - don't use scm_is_false, blech: they brought over () == #f from lisp
+*/
+
+#include "defs.h"
+#include <stdarg.h>
+#include "breakpoint.h"
+#include "cli/cli-cmds.h"
+#include "cli/cli-script.h"
+#include "cli/cli-utils.h"
+#include "command.h"
+#include "gdbcmd.h"
+#include "interps.h"
+#include "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
+}
+\f
+/* 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 */
+\f
+/* 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);
+}
+\f
+/* 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 <http://www.gnu.org/licenses/>. */
+
+#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 <http://www.gnu.org/licenses/>. */
+
+#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));
+}
+\f
+/* 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;
+}
+\f
+/* 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;
+}
+\f
+/* 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);
+ }
+ }
+}
+\f
+/* 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 <http://www.gnu.org/licenses/>. */
+
+#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));
+}
+\f
+/* 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
+}
+\f
+/* 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);
+}
+\f
+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 <http://www.gnu.org/licenses/>. */
+
+#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));
+}
+\f
+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);
+}
+\f
+/* 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 <http://www.gnu.org/licenses/>. */
+
+#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*";
+\f
+/* 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));
+}
+\f
+/* 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));
+}
+\f
+/* 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, _("<error reading variable>"));
+ else
+ fprintf_filtered (stream, _("<error reading variable: %s>"), 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;
+}
+\f
+/* 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 <http://www.gnu.org/licenses/>. */
+
+/* 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;
+}
+\f
+/* 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;
+}
+\f
+/* 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;
+}
+\f
+/* 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 <http://www.gnu.org/licenses/>. */
+
+#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 <http://www.gnu.org/licenses/>. */
+
+#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 <http://www.gnu.org/licenses/>. */
+
+// 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
+\f
+/* 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);
+}
+\f
+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;
+}
+\f
+/* 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));
+}
+\f
+/* 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;
+}
+\f
+/* 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;
+}
+\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;
+}
+\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);
+}
+\f
+/* 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;
+}
+\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 <http://www.gnu.org/licenses/>. */
+
+#include "defs.h"
+#include <stdarg.h>
+#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 <http://www.gnu.org/licenses/>. */
+
+#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));
+}
+\f
+/* 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);
+}
+\f
+/* 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);
+}
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: beginnings of Guile support
2013-09-06 15:35 beginnings of Guile support Doug Evans
@ 2013-09-06 16:27 ` Phil Muldoon
2013-09-10 5:20 ` Doug Evans
2013-09-09 21:09 ` Tom Tromey
1 sibling, 1 reply; 5+ messages in thread
From: Phil Muldoon @ 2013-09-06 16:27 UTC (permalink / raw)
To: Doug Evans; +Cc: gdb-patches
On 06/09/13 16:35, Doug Evans wrote:
> Hi.
> As a personal project, I'm adding scheme scripting to gdb.
> This patch is very preliminary (no docs, etc. etc. etc.), but I want
> to give people a heads up.
>
> To try to plug scheme in cleanly I've created scripting.[ch] as the
> interface between gdb and python/scheme. It's not complete, not least
> of which is varobj.c, but it feels reasonable.
Nice work, Doug. In particular the architectural changes to move the
scripting language infrastructure support to a more generic naming,
and agnostic point of view. (I guess we should have thought about
this way back when).
The only comments I have are the conflicts when dealing with areas
where an internal GDB, a Python, Guile, and some other future language
conflict might occur. I noticed you removed the conditional
breakpoint check where only a Python "stop" callback can be attached
to a breakpoint, or a "traditional" GDB condition. Your work is a
work in progress, so I am not going to worry too much at the moment.
But every "stop" callback attached to a breakpoint must be allowed to
run, even if the a previous "stop" callback indicated True to stop, or
a previous condition expression attached to GDB resolved to True. I
guess we can look at this area again when your work is getting closer
to submission.
Thanks for the preview. Are you aiming for 100% feature parity with
the Python work? (IE, frame filters, etc)
Cheers,
Phil
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: beginnings of Guile support
2013-09-06 15:35 beginnings of Guile support Doug Evans
2013-09-06 16:27 ` Phil Muldoon
@ 2013-09-09 21:09 ` Tom Tromey
2013-09-10 5:21 ` Doug Evans
1 sibling, 1 reply; 5+ messages in thread
From: Tom Tromey @ 2013-09-09 21:09 UTC (permalink / raw)
To: Doug Evans; +Cc: gdb-patches
>>>>> "Doug" == Doug Evans <dje@sceeck.org> writes:
Doug> As a personal project, I'm adding scheme scripting to gdb.
I'd rather not put this in. I think multiple scripting languages
fragments the user community and leads to hard-to-debug problems.
It also requires difficult cross-language integration. Your patch skips
the hard bits, but I think that is cheating -- those have to be fixed
first.
Doug> To try to plug scheme in cleanly I've created scripting.[ch] as
Doug> the interface between gdb and python/scheme.
The current interface uses "slang" as a name, but that is the name of an
existing scripting language. I think another name would be preferable
in case someone wants to add slang scripting.
Doug> +slang_sourcer_func *
Doug> +get_slang_sourcer (const char *file)
Doug> +{
Doug> + if (has_extension (file, ".py"))
Doug> + {
Doug> +#ifdef HAVE_PYTHON
Doug> + return python_scripting_interface.source_script;
Doug> +#else
Doug> + return source_python_unsupported;
Doug> +#endif
I think there are too many #ifs of this form.
It means the abstraction is incomplete.
Doug> /* Variables used to pass information between the Breakpoint
Doug> constructor and the breakpoint-created hook function. */
Doug> -breakpoint_object *bppy_pending_object;
Doug> +gdbpy_breakpoint_object *bppy_pending_object;
Renamings ought to be separate patches.
Doug> -/* Helper function that overrides this Python object's
Doug> - PyObject_GenericSetAttr to allow extra validation of the attribute
Doug> - being set. */
Doug> -
Doug> -static int
Doug> -local_setattro (PyObject *self, PyObject *name, PyObject *v)
Doug> -{
Doug> - breakpoint_object *obj = (breakpoint_object *) self;
[...]
I'm not sure why this was deleted, but it also seems like it ought to be
a separate patch, or maybe dropped.
Doug> +/* INCOMPLETE TODO LIST:
I skimmed the guile code, but didn't read it heavily.
I think anything that calls into Guile from gdb ought to prevent
continuation capture. Otherwise madness will ensue. I don't know how
you do that in Guile but I didn't see anything obvious in the code.
Tom
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: beginnings of Guile support
2013-09-06 16:27 ` Phil Muldoon
@ 2013-09-10 5:20 ` Doug Evans
0 siblings, 0 replies; 5+ messages in thread
From: Doug Evans @ 2013-09-10 5:20 UTC (permalink / raw)
To: Phil Muldoon; +Cc: gdb-patches
On Fri, Sep 6, 2013 at 9:27 AM, Phil Muldoon <pmuldoon@redhat.com> wrote:
> I noticed you removed the conditional
> breakpoint check where only a Python "stop" callback can be attached
> to a breakpoint, or a "traditional" GDB condition. Your work is a
> work in progress, so I am not going to worry too much at the moment.
> But every "stop" callback attached to a breakpoint must be allowed to
> run, even if the a previous "stop" callback indicated True to stop, or
> a previous condition expression attached to GDB resolved to True. I
> guess we can look at this area again when your work is getting closer
> to submission.
Righto.
> Thanks for the preview. Are you aiming for 100% feature parity with
> the Python work? (IE, frame filters, etc)
100% feature parity isn't an aim per se.
I expect python to continue to evolve in its own way.
OTOH, I do want the scheme code to not be dissimilar without a good reason.
^ permalink raw reply [flat|nested] 5+ messages in thread
* Re: beginnings of Guile support
2013-09-09 21:09 ` Tom Tromey
@ 2013-09-10 5:21 ` Doug Evans
0 siblings, 0 replies; 5+ messages in thread
From: Doug Evans @ 2013-09-10 5:21 UTC (permalink / raw)
To: Tom Tromey; +Cc: gdb-patches
On Mon, Sep 9, 2013 at 2:09 PM, Tom Tromey <tromey@redhat.com> wrote:
>>>>>> "Doug" == Doug Evans <dje@sceeck.org> writes:
>
> Doug> As a personal project, I'm adding scheme scripting to gdb.
>
> I'd rather not put this in. I think multiple scripting languages
> fragments the user community and leads to hard-to-debug problems.
>
> It also requires difficult cross-language integration. Your patch skips
> the hard bits, but I think that is cheating -- those have to be fixed
> first.
I did all I could do to say the patch was preliminary and that there was
still a lot to do.
Let's not get ahead of ourselves ...
If you have specific requirements, it would be good to know sooner
what they are.
> Doug> +slang_sourcer_func *
> Doug> +get_slang_sourcer (const char *file)
> Doug> +{
> Doug> + if (has_extension (file, ".py"))
> Doug> + {
> Doug> +#ifdef HAVE_PYTHON
> Doug> + return python_scripting_interface.source_script;
> Doug> +#else
> Doug> + return source_python_unsupported;
> Doug> +#endif
>
> I think there are too many #ifs of this form.
> It means the abstraction is incomplete.
The current incarnation isn't my favorite either.
Still working on that bit.
> Doug> /* Variables used to pass information between the Breakpoint
> Doug> constructor and the breakpoint-created hook function. */
> Doug> -breakpoint_object *bppy_pending_object;
> Doug> +gdbpy_breakpoint_object *bppy_pending_object;
>
> Renamings ought to be separate patches.
When the patch is ready to be submitted RFA, it will be split up.
I was hoping to leave such things as givens.
> Doug> -/* Helper function that overrides this Python object's
> Doug> - PyObject_GenericSetAttr to allow extra validation of the attribute
> Doug> - being set. */
> Doug> -
> Doug> -static int
> Doug> -local_setattro (PyObject *self, PyObject *name, PyObject *v)
> Doug> -{
> Doug> - breakpoint_object *obj = (breakpoint_object *) self;
> [...]
>
> I'm not sure why this was deleted, but it also seems like it ought to be
> a separate patch, or maybe dropped.
Righto.
> Doug> +/* INCOMPLETE TODO LIST:
>
> I skimmed the guile code, but didn't read it heavily.
>
> I think anything that calls into Guile from gdb ought to prevent
> continuation capture. Otherwise madness will ensue. I don't know how
> you do that in Guile but I didn't see anything obvious in the code.
All calls to Scheme are gated through specific routines.
Still working on all the details.
^ permalink raw reply [flat|nested] 5+ messages in thread
end of thread, other threads:[~2013-09-10 5:21 UTC | newest]
Thread overview: 5+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2013-09-06 15:35 beginnings of Guile support Doug Evans
2013-09-06 16:27 ` Phil Muldoon
2013-09-10 5:20 ` Doug Evans
2013-09-09 21:09 ` Tom Tromey
2013-09-10 5:21 ` Doug Evans
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox