/* GDB/Scheme exception support.
- Copyright (C) 2014 Free Software Foundation, Inc.
+ Copyright (C) 2014-2021 Free Software Foundation, Inc.
This file is part of GDB.
#include "defs.h"
#include <signal.h>
-#include "gdb_assert.h"
#include "guile-internal.h"
/* The <gdb:exception> smob.
One important invariant is that <gdb:exception> smobs are never a valid
result of a function, other than to signify an exception occurred. */
-typedef struct
+struct exception_smob
{
/* This always appears first. */
gdb_smob base;
/* The key and args parameters to "throw". */
SCM key;
SCM args;
-} exception_smob;
+};
static const char exception_smob_name[] = "gdb:exception";
/* User interrupt, e.g., RETURN_QUIT in struct gdb_exception. */
static SCM signal_symbol;
+/* A user error, e.g., bad arg to gdb command. */
+static SCM user_error_symbol;
+
/* Printing the stack is done by first capturing the stack and recording it in
a <gdb:exception> object with this key and with the ARGS field set to
(cons real-key (cons stack real-args)).
\f
/* Administrivia for exception smobs. */
-/* The smob "mark" function for <gdb:exception>. */
-
-static SCM
-exscm_mark_exception_smob (SCM self)
-{
- exception_smob *e_smob = (exception_smob *) SCM_SMOB_DATA (self);
-
- scm_gc_mark (e_smob->key);
- scm_gc_mark (e_smob->args);
- /* Do this last. */
- return gdbscm_mark_gsmob (&e_smob->base);
-}
-
/* The smob "print" function for <gdb:exception>. */
static int
/* Throw an invalid-object error.
OBJECT is the name of the kind of object that is invalid. */
-SCM
+void
gdbscm_invalid_object_error (const char *subr, int arg_pos, SCM bad_value,
const char *object)
{
/* Throw an out-of-range error.
This is the standard Guile out-of-range exception. */
-SCM
+void
gdbscm_out_of_range_error (const char *subr, int arg_pos, SCM bad_value,
const char *error)
{
SCM
gdbscm_make_misc_error (const char *subr, int arg_pos, SCM bad_value,
- const char *error)
+ const char *error)
{
return gdbscm_make_arg_error (scm_misc_error_key,
subr, arg_pos, bad_value, NULL, error);
}
+/* Throw a misc-error error. */
+
+void
+gdbscm_misc_error (const char *subr, int arg_pos, SCM bad_value,
+ const char *error)
+{
+ SCM exception = gdbscm_make_misc_error (subr, arg_pos, bad_value, error);
+
+ gdbscm_throw (exception);
+}
+
/* Return a <gdb:exception> object for gdb:memory-error. */
SCM
/* Throw a gdb:memory-error exception. */
-SCM
+void
gdbscm_memory_error (const char *subr, const char *msg, SCM args)
{
SCM exception = gdbscm_make_memory_error (subr, msg, args);
return scm_is_eq (key, memory_error_symbol);
}
+/* Return non-zero if KEY is gdb:user-error.
+ Note: This is an excp_matcher_func function. */
+
+int
+gdbscm_user_error_p (SCM key)
+{
+ return scm_is_eq (key, user_error_symbol);
+}
+
/* Wrapper around scm_throw to throw a gdb:exception.
This function does not return.
This function cannot be called from inside TRY_CATCH. */
/* Convert a GDB exception to a <gdb:exception> object. */
SCM
-gdbscm_scm_from_gdb_exception (struct gdb_exception exception)
+gdbscm_scm_from_gdb_exception (const gdbscm_gdb_exception &exception)
{
SCM key;
This function does not return. */
void
-gdbscm_throw_gdb_exception (struct gdb_exception exception)
+gdbscm_throw_gdb_exception (gdbscm_gdb_exception exception)
{
- gdbscm_throw (gdbscm_scm_from_gdb_exception (exception));
+ SCM scm_exception = gdbscm_scm_from_gdb_exception (exception);
+ xfree (exception.message);
+ gdbscm_throw (scm_exception);
}
/* Print the error message portion of an exception.
KEY, ARGS are the standard arguments to scm_throw, et.al.
Basically this function is just a wrapper around calling
- %print-exception-with-args. */
+ %print-exception-with-stack. */
void
gdbscm_print_exception_with_stack (SCM port, SCM stack, SCM key, SCM args)
percent_print_exception_with_stack_var
= scm_c_private_variable (gdbscm_init_module_name,
percent_print_exception_with_stack_name);
- /* If we can't find %print-exception-with-args, there's a problem on the
+ /* If we can't find %print-exception-with-stack, there's a problem on the
Scheme side. Don't kill GDB, just flag an error and leave it at
that. */
if (gdbscm_is_false (percent_print_exception_with_stack_var))
/* Return a string description of <gdb:exception> EXCEPTION.
If EXCEPTION is a gdb:with-stack exception, unwrap it, a backtrace
- is never returned as part of the result.
+ is never returned as part of the result. */
- Space for the result is malloc'd, the caller must free. */
-
-char *
+gdb::unique_xmalloc_ptr<char>
gdbscm_exception_message_to_string (SCM exception)
{
SCM port = scm_open_output_string ();
SCM key, args;
- char *result;
gdb_assert (gdbscm_is_exception (exception));
}
gdbscm_print_exception_message (port, SCM_BOOL_F, key, args);
- result = gdbscm_scm_to_c_string (scm_get_output_string (port));
+ gdb::unique_xmalloc_ptr<char> result
+ = gdbscm_scm_to_c_string (scm_get_output_string (port));
scm_close_port (port);
-
return result;
}
static const scheme_function exception_functions[] =
{
- { "make-exception", 2, 0, 0, gdbscm_make_exception,
+ { "make-exception", 2, 0, 0, as_a_scm_t_subr (gdbscm_make_exception),
"\
Create a <gdb:exception> object.\n\
\n\
Arguments: key args\n\
These are the standard key,args arguments of \"throw\"." },
- { "exception?", 1, 0, 0, gdbscm_exception_p,
+ { "exception?", 1, 0, 0, as_a_scm_t_subr (gdbscm_exception_p),
"\
Return #t if the object is a <gdb:exception> object." },
- { "exception-key", 1, 0, 0, gdbscm_exception_key,
+ { "exception-key", 1, 0, 0, as_a_scm_t_subr (gdbscm_exception_key),
"\
Return the exception's key." },
- { "exception-args", 1, 0, 0, gdbscm_exception_args,
+ { "exception-args", 1, 0, 0, as_a_scm_t_subr (gdbscm_exception_args),
"\
Return the exception's arg list." },
static const scheme_function private_exception_functions[] =
{
- { "%exception-print-style", 0, 0, 0, gdbscm_percent_exception_print_style,
+ { "%exception-print-style", 0, 0, 0,
+ as_a_scm_t_subr (gdbscm_percent_exception_print_style),
"\
Return the value of the \"guile print-stack\" option." },
- { "%exception-count", 0, 0, 0, gdbscm_percent_exception_count,
+ { "%exception-count", 0, 0, 0,
+ as_a_scm_t_subr (gdbscm_percent_exception_count),
"\
Return a count of the number of <gdb:exception> objects created.\n\
This is for debugging purposes." },
{
exception_smob_tag = gdbscm_make_smob_type (exception_smob_name,
sizeof (exception_smob));
- scm_set_smob_mark (exception_smob_tag, exscm_mark_exception_smob);
scm_set_smob_print (exception_smob_tag, exscm_print_exception_smob);
gdbscm_define_functions (exception_functions, 1);
memory_error_symbol = scm_from_latin1_symbol ("gdb:memory-error");
+ user_error_symbol = scm_from_latin1_symbol ("gdb:user-error");
+
gdbscm_invalid_object_error_symbol
= scm_from_latin1_symbol ("gdb:invalid-object-error");
projects / deliverable / binutils-gdb.git / blobdiff