char *
gdbscm_scm_to_string (SCM string, size_t *lenp,
const char *charset, int strict, SCM *except_scmp)
{
struct scm_to_stringn_data data;
SCM scm_result;
data.string = string;
data.lenp = lenp;
data.charset = charset;
data.conversion_kind = (strict
? SCM_FAILED_CONVERSION_ERROR
: SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
data.result = NULL;
scm_result = gdbscm_call_guile (gdbscm_call_scm_to_stringn, &data, NULL);
if (gdbscm_is_false (scm_result))
{
gdb_assert (data.result != NULL);
return data.result;
}
gdb_assert (gdbscm_is_exception (scm_result));
*except_scmp = scm_result;
return NULL;
}
static SCM
ppscm_search_pp_list (SCM list, SCM value)
{
SCM orig_list = list;
if (scm_is_null (list))
return SCM_BOOL_F;
if (gdbscm_is_false (scm_list_p (list))) /* scm_is_pair? */
{
return ppscm_make_pp_type_error_exception
(_("pretty-printer list is not a list"), list);
}
for ( ; scm_is_pair (list); list = scm_cdr (list))
{
SCM matcher = scm_car (list);
SCM worker;
pretty_printer_smob *pp_smob;
if (!ppscm_is_pretty_printer (matcher))
{
return ppscm_make_pp_type_error_exception
(_("pretty-printer list contains non-pretty-printer object"),
matcher);
}
pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (matcher);
/* Skip if disabled. */
if (gdbscm_is_false (pp_smob->enabled))
continue;
if (!gdbscm_is_procedure (pp_smob->lookup))
{
return ppscm_make_pp_type_error_exception
(_("invalid lookup object in pretty-printer matcher"),
pp_smob->lookup);
}
worker = gdbscm_safe_call_2 (pp_smob->lookup, matcher,
value, gdbscm_memory_error_p);
if (!gdbscm_is_false (worker))
{
if (gdbscm_is_exception (worker))
return worker;
if (ppscm_is_pretty_printer_worker (worker))
return worker;
return ppscm_make_pp_type_error_exception
(_("invalid result from pretty-printer lookup"), worker);
}
}
if (!scm_is_null (list))
{
return ppscm_make_pp_type_error_exception
(_("pretty-printer list is not a list"), orig_list);
}
return SCM_BOOL_F;
}
SCM
gdbscm_scm_from_string (const char *string, size_t len,
const char *charset, int strict)
{
struct scm_from_stringn_data data;
SCM scm_result;
data.string = string;
data.len = len;
data.charset = charset;
/* The use of SCM_FAILED_CONVERSION_QUESTION_MARK is specified by Guile. */
data.conversion_kind = (strict
? SCM_FAILED_CONVERSION_ERROR
: SCM_FAILED_CONVERSION_QUESTION_MARK);
data.result = SCM_UNDEFINED;
scm_result = gdbscm_call_guile (gdbscm_call_scm_from_stringn, &data, NULL);
if (gdbscm_is_false (scm_result))
{
gdb_assert (!SCM_UNBNDP (data.result));
return data.result;
}
gdb_assert (gdbscm_is_exception (scm_result));
return scm_result;
}
char *
gdbscm_exception_message_to_string (SCM exception)
{
SCM port = scm_open_output_string ();
SCM key, args;
char *result;
gdb_assert (gdbscm_is_exception (exception));
key = gdbscm_exception_key (exception);
args = gdbscm_exception_args (exception);
if (scm_is_eq (key, with_stack_error_symbol)
/* Don't crash on a badly generated gdb:with-stack exception. */
&& scm_is_pair (args)
&& scm_is_pair (scm_cdr (args)))
{
key = scm_car (args);
args = scm_cddr (args);
}
gdbscm_print_exception_message (port, SCM_BOOL_F, key, args);
result = gdbscm_scm_to_c_string (scm_get_output_string (port));
scm_close_port (port);
return result;
}
void
gdbscm_print_gdb_exception (SCM port, SCM exception)
{
gdb_assert (gdbscm_is_exception (exception));
gdbscm_print_exception_with_stack (port, SCM_BOOL_T,
gdbscm_exception_key (exception),
gdbscm_exception_args (exception));
}
static SCM
frscm_scm_from_frame_unsafe (struct frame_info *frame,
struct inferior *inferior)
{
SCM f_scm = frscm_scm_from_frame (frame, inferior);
if (gdbscm_is_exception (f_scm))
gdbscm_throw (f_scm);
return f_scm;
}
SCM
gdbscm_exception_args (SCM self)
{
exception_smob *e_smob;
SCM_ASSERT_TYPE (gdbscm_is_exception (self), self, SCM_ARG1, FUNC_NAME,
"gdb:exception");
e_smob = (exception_smob *) SCM_SMOB_DATA (self);
return e_smob->args;
}
static void
pascm_show_func (struct ui_file *file, int from_tty,
struct cmd_list_element *c, const char *value)
{
param_smob *p_smob = (param_smob *) get_cmd_context (c);
SCM value_scm, self, result, exception;
char *msg;
struct cleanup *cleanups;
gdb_assert (gdbscm_is_procedure (p_smob->show_func));
value_scm = gdbscm_scm_from_host_string (value, strlen (value));
if (gdbscm_is_exception (value_scm))
{
error (_("Error converting parameter value \"%s\" to Scheme string."),
value);
}
self = p_smob->containing_scm;
result = gdbscm_safe_call_2 (p_smob->show_func, self, value_scm,
gdbscm_user_error_p);
if (gdbscm_is_exception (result))
{
pascm_signal_setshow_error (result,
_("Error occurred showing parameter."));
}
msg = gdbscm_scm_to_host_string (result, NULL, &exception);
if (msg == NULL)
{
gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
error (_("Error converting show text to host string."));
}
cleanups = make_cleanup (xfree, msg);
fprintf_filtered (file, "%s\n", msg);
do_cleanups (cleanups);
}
static SCM
ppscm_pretty_print_one_value (SCM printer, struct value **out_value,
struct gdbarch *gdbarch,
const struct language_defn *language)
{
SCM result = SCM_BOOL_F;
*out_value = NULL;
TRY
{
int rc;
pretty_printer_worker_smob *w_smob
= (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
result = gdbscm_safe_call_1 (w_smob->to_string, printer,
gdbscm_memory_error_p);
if (gdbscm_is_false (result))
; /* Done. */
else if (scm_is_string (result)
|| lsscm_is_lazy_string (result))
; /* Done. */
else if (vlscm_is_value (result))
{
SCM except_scm;
*out_value
= vlscm_convert_value_from_scheme (FUNC_NAME, GDBSCM_ARG_NONE,
result, &except_scm,
gdbarch, language);
if (*out_value != NULL)
result = SCM_BOOL_T;
else
result = except_scm;
}
else if (gdbscm_is_exception (result))
; /* Done. */
else
{
/* Invalid result from to-string. */
result = ppscm_make_pp_type_error_exception
(_("invalid result from pretty-printer to-string"), result);
}
}
CATCH (except, RETURN_MASK_ALL)
{
}
END_CATCH
return result;
}
static void
cmdscm_function (struct cmd_list_element *command, char *args, int from_tty)
{
command_smob *c_smob/*obj*/ = (command_smob *) get_cmd_context (command);
SCM arg_scm, tty_scm, result;
gdb_assert (c_smob != NULL);
if (args == NULL)
args = "";
arg_scm = gdbscm_scm_from_string (args, strlen (args), host_charset (), 1);
if (gdbscm_is_exception (arg_scm))
error (_("Could not convert arguments to Scheme string."));
tty_scm = scm_from_bool (from_tty);
result = gdbscm_safe_call_3 (c_smob->invoke, c_smob->containing_scm,
arg_scm, tty_scm, gdbscm_user_error_p);
if (gdbscm_is_exception (result))
{
/* Don't print the stack if this was an error signalled by the command
itself. */
if (gdbscm_user_error_p (gdbscm_exception_key (result)))
{
char *msg = gdbscm_exception_message_to_string (result);
make_cleanup (xfree, msg);
error ("%s", msg);
}
else
{
gdbscm_print_gdb_exception (SCM_BOOL_F, result);
error (_("Error occurred in Scheme-implemented GDB command."));
}
}
}
static SCM
ioscm_with_output_to_port_worker (SCM port, SCM thunk, enum oport oport,
const char *func_name)
{
struct ui_file *port_file;
struct cleanup *cleanups;
SCM result;
SCM_ASSERT_TYPE (gdbscm_is_true (scm_output_port_p (port)), port,
SCM_ARG1, func_name, _("output port"));
SCM_ASSERT_TYPE (gdbscm_is_true (scm_thunk_p (thunk)), thunk,
SCM_ARG2, func_name, _("thunk"));
cleanups = set_batch_flag_and_make_cleanup_restore_page_info ();
make_cleanup_restore_integer (¤t_ui->async);
current_ui->async = 0;
port_file = ioscm_file_port_new (port);
make_cleanup_ui_file_delete (port_file);
scoped_restore save_file = make_scoped_restore (oport == GDB_STDERR
? &gdb_stderr : &gdb_stdout);
if (oport == GDB_STDERR)
gdb_stderr = port_file;
else
{
if (ui_out_redirect (current_uiout, port_file) < 0)
warning (_("Current output protocol does not support redirection"));
else
make_cleanup_ui_out_redirect_pop (current_uiout);
gdb_stdout = port_file;
}
result = gdbscm_safe_call_0 (thunk, NULL);
do_cleanups (cleanups);
if (gdbscm_is_exception (result))
gdbscm_throw (result);
return result;
}
static void
gdbscm_print_exception_message (SCM port, SCM frame, SCM key, SCM args)
{
SCM printer, status;
if (gdbscm_is_false (port))
port = scm_current_error_port ();
gdb_assert (!scm_is_eq (key, with_stack_error_symbol));
/* This does not use scm_print_exception because we tweak the output a bit.
Compare Guile's print-exception with our %print-exception-message for
details. */
if (gdbscm_is_false (percent_print_exception_message_var))
{
percent_print_exception_message_var
= scm_c_private_variable (gdbscm_init_module_name,
percent_print_exception_message_name);
/* If we can't find %print-exception-message, there's a problem on the
Scheme side. Don't kill GDB, just flag an error and leave it at
that. */
if (gdbscm_is_false (percent_print_exception_message_var))
{
gdbscm_printf (port, _("Error in Scheme exception printing,"
" can't find %s.\n"),
percent_print_exception_message_name);
return;
}
}
printer = scm_variable_ref (percent_print_exception_message_var);
status = gdbscm_safe_call_4 (printer, port, frame, key, args, NULL);
/* If that failed still tell the user something.
But don't use the exception printing machinery! */
if (gdbscm_is_exception (status))
{
gdbscm_printf (port, _("Error in Scheme exception printing:\n"));
scm_display (status, port);
scm_newline (port);
}
}
void
gdbscm_print_exception_with_stack (SCM port, SCM stack, SCM key, SCM args)
{
SCM printer, status;
if (gdbscm_is_false (port))
port = scm_current_error_port ();
if (gdbscm_is_false (percent_print_exception_with_stack_var))
{
percent_print_exception_with_stack_var
= scm_c_private_variable (gdbscm_init_module_name,
percent_print_exception_with_stack_name);
/* If we can't find %print-exception-with-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))
{
gdbscm_printf (port, _("Error in Scheme exception printing,"
" can't find %s.\n"),
percent_print_exception_with_stack_name);
return;
}
}
printer = scm_variable_ref (percent_print_exception_with_stack_var);
status = gdbscm_safe_call_4 (printer, port, stack, key, args, NULL);
/* If that failed still tell the user something.
But don't use the exception printing machinery! */
if (gdbscm_is_exception (status))
{
gdbscm_printf (port, _("Error in Scheme exception printing:\n"));
scm_display (status, port);
scm_newline (port);
}
}
static void
pascm_set_func (const char *args, int from_tty, struct cmd_list_element *c)
{
param_smob *p_smob = (param_smob *) get_cmd_context (c);
SCM self, result, exception;
char *msg;
struct cleanup *cleanups;
gdb_assert (gdbscm_is_procedure (p_smob->set_func));
self = p_smob->containing_scm;
result = gdbscm_safe_call_1 (p_smob->set_func, self, gdbscm_user_error_p);
if (gdbscm_is_exception (result))
{
pascm_signal_setshow_error (result,
_("Error occurred setting parameter."));
}
if (!scm_is_string (result))
error (_("Result of %s set-func is not a string."), p_smob->name);
msg = gdbscm_scm_to_host_string (result, NULL, &exception);
if (msg == NULL)
{
gdbscm_print_gdb_exception (SCM_BOOL_F, exception);
error (_("Error converting show text to host string."));
}
cleanups = make_cleanup (xfree, msg);
/* GDB is usually silent when a parameter is set. */
if (*msg != '\0')
fprintf_filtered (gdb_stdout, "%s\n", msg);
do_cleanups (cleanups);
}
enum ext_lang_rc
gdbscm_apply_val_pretty_printer (const struct extension_language_defn *extlang,
struct type *type, const gdb_byte *valaddr,
int embedded_offset, CORE_ADDR address,
struct ui_file *stream, int recurse,
const struct value *val,
const struct value_print_options *options,
const struct language_defn *language)
{
struct gdbarch *gdbarch = get_type_arch (type);
SCM exception = SCM_BOOL_F;
SCM printer = SCM_BOOL_F;
SCM val_obj = SCM_BOOL_F;
struct value *value;
enum display_hint hint;
struct cleanup *cleanups;
enum ext_lang_rc result = EXT_LANG_RC_NOP;
enum string_repr_result print_result;
/* No pretty-printer support for unavailable values. */
if (!value_bytes_available (val, embedded_offset, TYPE_LENGTH (type)))
return EXT_LANG_RC_NOP;
if (!gdb_scheme_initialized)
return EXT_LANG_RC_NOP;
cleanups = make_cleanup (null_cleanup, NULL);
/* Instantiate the printer. */
if (valaddr)
valaddr += embedded_offset;
value = value_from_contents_and_address (type, valaddr,
address + embedded_offset);
set_value_component_location (value, val);
/* set_value_component_location resets the address, so we may
need to set it again. */
if (VALUE_LVAL (value) != lval_internalvar
&& VALUE_LVAL (value) != lval_internalvar_component
&& VALUE_LVAL (value) != lval_computed)
set_value_address (value, address + embedded_offset);
val_obj = vlscm_scm_from_value (value);
if (gdbscm_is_exception (val_obj))
{
exception = val_obj;
result = EXT_LANG_RC_ERROR;
goto done;
}
printer = ppscm_find_pretty_printer (val_obj);
if (gdbscm_is_exception (printer))
{
exception = printer;
result = EXT_LANG_RC_ERROR;
goto done;
}
if (gdbscm_is_false (printer))
{
result = EXT_LANG_RC_NOP;
goto done;
}
gdb_assert (ppscm_is_pretty_printer_worker (printer));
/* If we are printing a map, we want some special formatting. */
hint = ppscm_get_display_hint_enum (printer);
if (hint == HINT_ERROR)
{
/* Print the error as an exception for consistency. */
SCM hint_scm = ppscm_get_display_hint_scm (printer);
ppscm_print_pp_type_error ("Invalid display hint", hint_scm);
/* Fall through. A bad hint doesn't stop pretty-printing. */
hint = HINT_NONE;
}
/* Print the section. */
print_result = ppscm_print_string_repr (printer, hint, stream, recurse,
options, gdbarch, language);
if (print_result != STRING_REPR_ERROR)
{
ppscm_print_children (printer, hint, stream, recurse, options,
gdbarch, language,
print_result == STRING_REPR_NONE);
}
result = EXT_LANG_RC_OK;
done:
if (gdbscm_is_exception (exception))
ppscm_print_exception_unless_memory_error (exception, stream);
do_cleanups (cleanups);
return result;
}
static void
ppscm_print_children (SCM printer, enum display_hint hint,
struct ui_file *stream, int recurse,
const struct value_print_options *options,
struct gdbarch *gdbarch,
const struct language_defn *language,
int printed_nothing)
{
pretty_printer_worker_smob *w_smob
= (pretty_printer_worker_smob *) SCM_SMOB_DATA (printer);
int is_map, is_array, done_flag, pretty;
unsigned int i;
SCM children, status;
SCM iter = SCM_BOOL_F; /* -Wall */
struct cleanup *cleanups;
if (gdbscm_is_false (w_smob->children))
return;
if (!gdbscm_is_procedure (w_smob->children))
{
ppscm_print_pp_type_error
(_("pretty-printer \"children\" object is not a procedure or #f"),
w_smob->children);
return;
}
cleanups = make_cleanup (null_cleanup, NULL);
/* If we are printing a map or an array, we want special formatting. */
is_map = hint == HINT_MAP;
is_array = hint == HINT_ARRAY;
children = gdbscm_safe_call_1 (w_smob->children, printer,
gdbscm_memory_error_p);
if (gdbscm_is_exception (children))
{
ppscm_print_exception_unless_memory_error (children, stream);
goto done;
}
/* We combine two steps here: get children, make an iterator out of them.
This simplifies things because there's no language means of creating
iterators, and it's the printer object that knows how it will want its
children iterated over. */
if (!itscm_is_iterator (children))
{
ppscm_print_pp_type_error
(_("result of pretty-printer \"children\" procedure is not"
" a <gdb:iterator> object"), children);
goto done;
}
iter = children;
/* Use the prettyformat_arrays option if we are printing an array,
and the pretty option otherwise. */
if (is_array)
pretty = options->prettyformat_arrays;
else
{
if (options->prettyformat == Val_prettyformat)
pretty = 1;
else
pretty = options->prettyformat_structs;
}
done_flag = 0;
for (i = 0; i < options->print_max; ++i)
{
int rc;
SCM scm_name, v_scm;
char *name;
SCM item = itscm_safe_call_next_x (iter, gdbscm_memory_error_p);
struct cleanup *inner_cleanup = make_cleanup (null_cleanup, NULL);
if (gdbscm_is_exception (item))
{
ppscm_print_exception_unless_memory_error (item, stream);
break;
}
if (itscm_is_end_of_iteration (item))
{
/* Set a flag so we can know whether we printed all the
available elements. */
done_flag = 1;
break;
}
if (! scm_is_pair (item))
{
ppscm_print_pp_type_error
(_("result of pretty-printer children iterator is not a pair"
" or (end-of-iteration)"),
item);
continue;
}
scm_name = scm_car (item);
v_scm = scm_cdr (item);
if (!scm_is_string (scm_name))
{
ppscm_print_pp_type_error
(_("first element of pretty-printer children iterator is not"
" a string"), item);
continue;
}
name = gdbscm_scm_to_c_string (scm_name);
make_cleanup (xfree, name);
/* Print initial "{". For other elements, there are three cases:
1. Maps. Print a "," after each value element.
2. Arrays. Always print a ",".
3. Other. Always print a ",". */
if (i == 0)
{
if (printed_nothing)
fputs_filtered ("{", stream);
else
fputs_filtered (" = {", stream);
}
else if (! is_map || i % 2 == 0)
fputs_filtered (pretty ? "," : ", ", stream);
/* In summary mode, we just want to print "= {...}" if there is
a value. */
if (options->summary)
{
/* This increment tricks the post-loop logic to print what
we want. */
++i;
/* Likewise. */
pretty = 0;
break;
}
if (! is_map || i % 2 == 0)
{
if (pretty)
{
fputs_filtered ("\n", stream);
print_spaces_filtered (2 + 2 * recurse, stream);
}
else
wrap_here (n_spaces (2 + 2 *recurse));
}
if (is_map && i % 2 == 0)
fputs_filtered ("[", stream);
else if (is_array)
{
/* We print the index, not whatever the child method
returned as the name. */
if (options->print_array_indexes)
fprintf_filtered (stream, "[%d] = ", i);
}
else if (! is_map)
{
fputs_filtered (name, stream);
fputs_filtered (" = ", stream);
}
if (lsscm_is_lazy_string (v_scm))
{
struct value_print_options local_opts = *options;
local_opts.addressprint = 0;
lsscm_val_print_lazy_string (v_scm, stream, &local_opts);
}
else if (scm_is_string (v_scm))
{
char *output = gdbscm_scm_to_c_string (v_scm);
fputs_filtered (output, stream);
xfree (output);
}
else
{
SCM except_scm;
struct value *value
= vlscm_convert_value_from_scheme (FUNC_NAME, GDBSCM_ARG_NONE,
v_scm, &except_scm,
gdbarch, language);
if (value == NULL)
{
ppscm_print_exception_unless_memory_error (except_scm, stream);
break;
}
common_val_print (value, stream, recurse + 1, options, language);
}
if (is_map && i % 2 == 0)
fputs_filtered ("] = ", stream);
do_cleanups (inner_cleanup);
}
if (i)
{
if (!done_flag)
{
if (pretty)
{
fputs_filtered ("\n", stream);
print_spaces_filtered (2 + 2 * recurse, stream);
}
fputs_filtered ("...", stream);
}
if (pretty)
{
fputs_filtered ("\n", stream);
print_spaces_filtered (2 * recurse, stream);
}
fputs_filtered ("}", stream);
}
done:
do_cleanups (cleanups);
/* Play it safe, make sure ITER doesn't get GC'd. */
scm_remember_upto_here_1 (iter);
}
static enum string_repr_result
ppscm_print_string_repr (SCM printer, enum display_hint hint,
struct ui_file *stream, int recurse,
const struct value_print_options *options,
struct gdbarch *gdbarch,
const struct language_defn *language)
{
struct value *replacement = NULL;
SCM str_scm;
enum string_repr_result result = STRING_REPR_ERROR;
str_scm = ppscm_pretty_print_one_value (printer, &replacement,
gdbarch, language);
if (gdbscm_is_false (str_scm))
{
result = STRING_REPR_NONE;
}
else if (scm_is_eq (str_scm, SCM_BOOL_T))
{
struct value_print_options opts = *options;
gdb_assert (replacement != NULL);
opts.addressprint = 0;
common_val_print (replacement, stream, recurse, &opts, language);
result = STRING_REPR_OK;
}
else if (scm_is_string (str_scm))
{
struct cleanup *cleanup;
size_t length;
char *string
= gdbscm_scm_to_string (str_scm, &length,
target_charset (gdbarch), 0 /*!strict*/, NULL);
cleanup = make_cleanup (xfree, string);
if (hint == HINT_STRING)
{
struct type *type = builtin_type (gdbarch)->builtin_char;
LA_PRINT_STRING (stream, type, (gdb_byte *) string,
length, NULL, 0, options);
}
else
{
/* Alas scm_to_stringn doesn't nul-terminate the string if we
ask for the length. */
size_t i;
for (i = 0; i < length; ++i)
{
if (string[i] == '\0')
fputs_filtered ("\\000", stream);
else
fputc_filtered (string[i], stream);
}
}
result = STRING_REPR_OK;
do_cleanups (cleanup);
}
else if (lsscm_is_lazy_string (str_scm))
{
struct value_print_options local_opts = *options;
local_opts.addressprint = 0;
lsscm_val_print_lazy_string (str_scm, stream, &local_opts);
result = STRING_REPR_OK;
}
else
{
gdb_assert (gdbscm_is_exception (str_scm));
ppscm_print_exception_unless_memory_error (str_scm, stream);
result = STRING_REPR_ERROR;
}
return result;
}
static SCM
gdbscm_make_parameter (SCM name_scm, SCM rest)
{
const SCM keywords[] = {
command_class_keyword, parameter_type_keyword, enum_list_keyword,
set_func_keyword, show_func_keyword,
doc_keyword, set_doc_keyword, show_doc_keyword,
initial_value_keyword, SCM_BOOL_F
};
int cmd_class_arg_pos = -1, param_type_arg_pos = -1;
int enum_list_arg_pos = -1, set_func_arg_pos = -1, show_func_arg_pos = -1;
int doc_arg_pos = -1, set_doc_arg_pos = -1, show_doc_arg_pos = -1;
int initial_value_arg_pos = -1;
char *s;
char *name;
int cmd_class = no_class;
int param_type = var_boolean; /* ARI: var_boolean */
SCM enum_list_scm = SCM_BOOL_F;
SCM set_func = SCM_BOOL_F, show_func = SCM_BOOL_F;
char *doc = NULL, *set_doc = NULL, *show_doc = NULL;
SCM initial_value_scm = SCM_BOOL_F;
const char * const *enum_list = NULL;
SCM p_scm;
param_smob *p_smob;
gdbscm_parse_function_args (FUNC_NAME, SCM_ARG1, keywords, "s#iiOOOsssO",
name_scm, &name, rest,
&cmd_class_arg_pos, &cmd_class,
¶m_type_arg_pos, ¶m_type,
&enum_list_arg_pos, &enum_list_scm,
&set_func_arg_pos, &set_func,
&show_func_arg_pos, &show_func,
&doc_arg_pos, &doc,
&set_doc_arg_pos, &set_doc,
&show_doc_arg_pos, &show_doc,
&initial_value_arg_pos, &initial_value_scm);
/* If doc is NULL, leave it NULL. See add_setshow_cmd_full. */
if (set_doc == NULL)
set_doc = get_doc_string ();
if (show_doc == NULL)
show_doc = get_doc_string ();
s = name;
name = gdbscm_canonicalize_command_name (s, 0);
xfree (s);
if (doc != NULL)
{
s = doc;
doc = gdbscm_gc_xstrdup (s);
xfree (s);
}
s = set_doc;
set_doc = gdbscm_gc_xstrdup (s);
xfree (s);
s = show_doc;
show_doc = gdbscm_gc_xstrdup (s);
xfree (s);
if (!gdbscm_valid_command_class_p (cmd_class))
{
gdbscm_out_of_range_error (FUNC_NAME, cmd_class_arg_pos,
scm_from_int (cmd_class),
_("invalid command class argument"));
}
if (!pascm_valid_parameter_type_p (param_type))
{
gdbscm_out_of_range_error (FUNC_NAME, param_type_arg_pos,
scm_from_int (param_type),
_("invalid parameter type argument"));
}
if (enum_list_arg_pos > 0 && param_type != var_enum)
{
gdbscm_misc_error (FUNC_NAME, enum_list_arg_pos, enum_list_scm,
_("#:enum-values can only be provided with PARAM_ENUM"));
}
if (enum_list_arg_pos < 0 && param_type == var_enum)
{
gdbscm_misc_error (FUNC_NAME, GDBSCM_ARG_NONE, SCM_BOOL_F,
_("PARAM_ENUM requires an enum-values argument"));
}
if (set_func_arg_pos > 0)
{
SCM_ASSERT_TYPE (gdbscm_is_procedure (set_func), set_func,
set_func_arg_pos, FUNC_NAME, _("procedure"));
}
if (show_func_arg_pos > 0)
{
SCM_ASSERT_TYPE (gdbscm_is_procedure (show_func), show_func,
show_func_arg_pos, FUNC_NAME, _("procedure"));
}
if (param_type == var_enum)
{
/* Note: enum_list lives in GC space, so we don't have to worry about
freeing it if we later throw an exception. */
enum_list = compute_enum_list (enum_list_scm, enum_list_arg_pos,
FUNC_NAME);
}
/* If initial-value is a function, we need the parameter object constructed
to pass it to the function. A typical thing the function may want to do
is add an object-property to it to record the last known good value. */
p_scm = pascm_make_param_smob ();
p_smob = (param_smob *) SCM_SMOB_DATA (p_scm);
/* These are all stored in GC space so that we don't have to worry about
freeing them if we throw an exception. */
p_smob->name = name;
p_smob->cmd_class = (enum command_class) cmd_class;
p_smob->type = (enum var_types) param_type;
p_smob->doc = doc;
p_smob->set_doc = set_doc;
p_smob->show_doc = show_doc;
p_smob->enumeration = enum_list;
p_smob->set_func = set_func;
p_smob->show_func = show_func;
if (initial_value_arg_pos > 0)
{
if (gdbscm_is_procedure (initial_value_scm))
{
initial_value_scm = gdbscm_safe_call_1 (initial_value_scm,
p_smob->containing_scm, NULL);
if (gdbscm_is_exception (initial_value_scm))
gdbscm_throw (initial_value_scm);
}
pascm_set_param_value_x (p_smob->type, &p_smob->value, enum_list,
initial_value_scm,
initial_value_arg_pos, FUNC_NAME);
}
return p_scm;
}
static SCM
gdbscm_exception_p (SCM scm)
{
return scm_from_bool (gdbscm_is_exception (scm));
}
