1 /* GDB/Scheme exception support.
3 Copyright (C) 2014 Free Software Foundation, Inc.
5 This file is part of GDB.
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3 of the License, or
10 (at your option) any later version.
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>. */
20 /* See README file in this directory for implementation notes, coding
21 conventions, et.al. */
25 IWBN to support SRFI 34/35. At the moment we follow Guile's own
28 The non-static functions in this file have prefix gdbscm_ and
29 not exscm_ on purpose. */
33 #include "gdb_assert.h"
34 #include "guile-internal.h"
36 /* The <gdb:exception> smob.
37 This is used to record and handle Scheme exceptions.
38 One important invariant is that <gdb:exception> smobs are never a valid
39 result of a function, other than to signify an exception occurred. */
43 /* This always appears first. */
46 /* The key and args parameters to "throw". */
51 static const char exception_smob_name
[] = "gdb:exception";
53 /* The tag Guile knows the exception smob by. */
54 static scm_t_bits exception_smob_tag
;
56 /* A generic error in struct gdb_exception.
57 I.e., not RETURN_QUIT and not MEMORY_ERROR. */
58 static SCM error_symbol
;
60 /* An error occurred accessing inferior memory.
61 This is not a Scheme programming error. */
62 static SCM memory_error_symbol
;
64 /* User interrupt, e.g., RETURN_QUIT in struct gdb_exception. */
65 static SCM signal_symbol
;
67 /* A user error, e.g., bad arg to gdb command. */
68 static SCM user_error_symbol
;
70 /* Printing the stack is done by first capturing the stack and recording it in
71 a <gdb:exception> object with this key and with the ARGS field set to
72 (cons real-key (cons stack real-args)).
73 See gdbscm_make_exception_with_stack. */
74 static SCM with_stack_error_symbol
;
76 /* The key to use for an invalid object exception. An invalid object is one
77 where the underlying object has been removed from GDB. */
78 SCM gdbscm_invalid_object_error_symbol
;
80 /* Values for "guile print-stack" as symbols. */
81 static SCM none_symbol
;
82 static SCM message_symbol
;
83 static SCM full_symbol
;
85 static const char percent_print_exception_message_name
[] =
86 "%print-exception-message";
88 /* Variable containing %print-exception-message.
89 It is not defined until late in initialization, after our init routine
90 has run. Cope by looking it up lazily. */
91 static SCM percent_print_exception_message_var
= SCM_BOOL_F
;
93 static const char percent_print_exception_with_stack_name
[] =
94 "%print-exception-with-stack";
96 /* Variable containing %print-exception-with-stack.
97 It is not defined until late in initialization, after our init routine
98 has run. Cope by looking it up lazily. */
99 static SCM percent_print_exception_with_stack_var
= SCM_BOOL_F
;
101 /* Counter to keep track of the number of times we create a <gdb:exception>
102 object, for performance monitoring purposes. */
103 static unsigned long gdbscm_exception_count
= 0;
105 /* Administrivia for exception smobs. */
107 /* The smob "print" function for <gdb:exception>. */
110 exscm_print_exception_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
112 exception_smob
*e_smob
= (exception_smob
*) SCM_SMOB_DATA (self
);
114 gdbscm_printf (port
, "#<%s ", exception_smob_name
);
115 scm_write (e_smob
->key
, port
);
116 scm_puts (" ", port
);
117 scm_write (e_smob
->args
, port
);
118 scm_puts (">", port
);
120 scm_remember_upto_here_1 (self
);
122 /* Non-zero means success. */
126 /* (make-exception key args) -> <gdb:exception> */
129 gdbscm_make_exception (SCM key
, SCM args
)
131 exception_smob
*e_smob
= (exception_smob
*)
132 scm_gc_malloc (sizeof (exception_smob
), exception_smob_name
);
137 smob
= scm_new_smob (exception_smob_tag
, (scm_t_bits
) e_smob
);
138 gdbscm_init_gsmob (&e_smob
->base
);
140 ++gdbscm_exception_count
;
145 /* Return non-zero if SCM is a <gdb:exception> object. */
148 gdbscm_is_exception (SCM scm
)
150 return SCM_SMOB_PREDICATE (exception_smob_tag
, scm
);
153 /* (exception? scm) -> boolean */
156 gdbscm_exception_p (SCM scm
)
158 return scm_from_bool (gdbscm_is_exception (scm
));
161 /* (exception-key <gdb:exception>) -> key */
164 gdbscm_exception_key (SCM self
)
166 exception_smob
*e_smob
;
168 SCM_ASSERT_TYPE (gdbscm_is_exception (self
), self
, SCM_ARG1
, FUNC_NAME
,
171 e_smob
= (exception_smob
*) SCM_SMOB_DATA (self
);
175 /* (exception-args <gdb:exception>) -> arg-list */
178 gdbscm_exception_args (SCM self
)
180 exception_smob
*e_smob
;
182 SCM_ASSERT_TYPE (gdbscm_is_exception (self
), self
, SCM_ARG1
, FUNC_NAME
,
185 e_smob
= (exception_smob
*) SCM_SMOB_DATA (self
);
189 /* Wrap an exception in a <gdb:exception> object that includes STACK.
190 gdbscm_print_exception_with_stack knows how to unwrap it. */
193 gdbscm_make_exception_with_stack (SCM key
, SCM args
, SCM stack
)
195 return gdbscm_make_exception (with_stack_error_symbol
,
196 scm_cons (key
, scm_cons (stack
, args
)));
199 /* Version of scm_error_scm that creates a gdb:exception object that can later
200 be passed to gdbscm_throw.
201 KEY is a symbol denoting the kind of error.
202 SUBR is either #f or a string marking the function in which the error
204 MESSAGE is either #f or the error message string. It may contain ~a and ~s
205 modifiers, provided by ARGS.
206 ARGS is a list of args to MESSAGE.
207 DATA is an arbitrary object, its value depends on KEY. The value to pass
208 here is a bit underspecified by Guile. */
211 gdbscm_make_error_scm (SCM key
, SCM subr
, SCM message
, SCM args
, SCM data
)
213 return gdbscm_make_exception (key
, scm_list_4 (subr
, message
, args
, data
));
216 /* Version of scm_error that creates a gdb:exception object that can later
217 be passed to gdbscm_throw.
218 See gdbscm_make_error_scm for a description of the arguments. */
221 gdbscm_make_error (SCM key
, const char *subr
, const char *message
,
224 return gdbscm_make_error_scm
226 subr
== NULL
? SCM_BOOL_F
: scm_from_latin1_string (subr
),
227 message
== NULL
? SCM_BOOL_F
: scm_from_latin1_string (message
),
231 /* Version of SCM_ASSERT_TYPE/scm_wrong_type_arg_msg that creates a
232 gdb:exception object that can later be passed to gdbscm_throw. */
235 gdbscm_make_type_error (const char *subr
, int arg_pos
, SCM bad_value
,
236 const char *expected_type
)
243 if (expected_type
!= NULL
)
245 msg
= xstrprintf (_("Wrong type argument in position %d"
246 " (expecting %s): ~S"),
247 arg_pos
, expected_type
);
251 msg
= xstrprintf (_("Wrong type argument in position %d: ~S"),
257 if (expected_type
!= NULL
)
259 msg
= xstrprintf (_("Wrong type argument (expecting %s): ~S"),
263 msg
= xstrprintf (_("Wrong type argument: ~S"));
266 result
= gdbscm_make_error (scm_arg_type_key
, subr
, msg
,
267 scm_list_1 (bad_value
), scm_list_1 (bad_value
));
272 /* A variant of gdbscm_make_type_error for non-type argument errors.
273 ERROR_PREFIX and ERROR are combined to build the error message.
274 Care needs to be taken so that the i18n composed form is still
275 reasonable, but no one is going to translate these anyway so we don't
277 ERROR_PREFIX may be NULL, ERROR may not be NULL. */
280 gdbscm_make_arg_error (SCM key
, const char *subr
, int arg_pos
, SCM bad_value
,
281 const char *error_prefix
, const char *error
)
286 if (error_prefix
!= NULL
)
290 msg
= xstrprintf (_("%s %s in position %d: ~S"),
291 error_prefix
, error
, arg_pos
);
294 msg
= xstrprintf (_("%s %s: ~S"), error_prefix
, error
);
299 msg
= xstrprintf (_("%s in position %d: ~S"), error
, arg_pos
);
301 msg
= xstrprintf (_("%s: ~S"), error
);
304 result
= gdbscm_make_error (key
, subr
, msg
,
305 scm_list_1 (bad_value
), scm_list_1 (bad_value
));
310 /* Make an invalid-object error <gdb:exception> object.
311 OBJECT is the name of the kind of object that is invalid. */
314 gdbscm_make_invalid_object_error (const char *subr
, int arg_pos
, SCM bad_value
,
317 return gdbscm_make_arg_error (gdbscm_invalid_object_error_symbol
,
318 subr
, arg_pos
, bad_value
,
319 _("Invalid object:"), object
);
322 /* Throw an invalid-object error.
323 OBJECT is the name of the kind of object that is invalid. */
326 gdbscm_invalid_object_error (const char *subr
, int arg_pos
, SCM bad_value
,
330 = gdbscm_make_invalid_object_error (subr
, arg_pos
, bad_value
, object
);
332 gdbscm_throw (exception
);
335 /* Make an out-of-range error <gdb:exception> object. */
338 gdbscm_make_out_of_range_error (const char *subr
, int arg_pos
, SCM bad_value
,
341 return gdbscm_make_arg_error (scm_out_of_range_key
,
342 subr
, arg_pos
, bad_value
,
343 _("Out of range:"), error
);
346 /* Throw an out-of-range error.
347 This is the standard Guile out-of-range exception. */
350 gdbscm_out_of_range_error (const char *subr
, int arg_pos
, SCM bad_value
,
354 = gdbscm_make_out_of_range_error (subr
, arg_pos
, bad_value
, error
);
356 gdbscm_throw (exception
);
359 /* Make a misc-error <gdb:exception> object. */
362 gdbscm_make_misc_error (const char *subr
, int arg_pos
, SCM bad_value
,
365 return gdbscm_make_arg_error (scm_misc_error_key
,
366 subr
, arg_pos
, bad_value
, NULL
, error
);
369 /* Throw a misc-error error. */
372 gdbscm_misc_error (const char *subr
, int arg_pos
, SCM bad_value
,
375 SCM exception
= gdbscm_make_misc_error (subr
, arg_pos
, bad_value
, error
);
377 gdbscm_throw (exception
);
380 /* Return a <gdb:exception> object for gdb:memory-error. */
383 gdbscm_make_memory_error (const char *subr
, const char *msg
, SCM args
)
385 return gdbscm_make_error (memory_error_symbol
, subr
, msg
, args
,
389 /* Throw a gdb:memory-error exception. */
392 gdbscm_memory_error (const char *subr
, const char *msg
, SCM args
)
394 SCM exception
= gdbscm_make_memory_error (subr
, msg
, args
);
396 gdbscm_throw (exception
);
399 /* Return non-zero if KEY is gdb:memory-error.
400 Note: This is an excp_matcher_func function. */
403 gdbscm_memory_error_p (SCM key
)
405 return scm_is_eq (key
, memory_error_symbol
);
408 /* Return non-zero if KEY is gdb:user-error.
409 Note: This is an excp_matcher_func function. */
412 gdbscm_user_error_p (SCM key
)
414 return scm_is_eq (key
, user_error_symbol
);
417 /* Wrapper around scm_throw to throw a gdb:exception.
418 This function does not return.
419 This function cannot be called from inside TRY_CATCH. */
422 gdbscm_throw (SCM exception
)
424 scm_throw (gdbscm_exception_key (exception
),
425 gdbscm_exception_args (exception
));
426 gdb_assert_not_reached ("scm_throw returned");
429 /* Convert a GDB exception to a <gdb:exception> object. */
432 gdbscm_scm_from_gdb_exception (struct gdb_exception exception
)
436 if (exception
.reason
== RETURN_QUIT
)
438 /* Handle this specially to be consistent with top-repl.scm. */
439 return gdbscm_make_error (signal_symbol
, NULL
, _("User interrupt"),
440 SCM_EOL
, scm_list_1 (scm_from_int (SIGINT
)));
443 if (exception
.error
== MEMORY_ERROR
)
444 key
= memory_error_symbol
;
448 return gdbscm_make_error (key
, NULL
, "~A",
449 scm_list_1 (gdbscm_scm_from_c_string
450 (exception
.message
)),
454 /* Convert a GDB exception to the appropriate Scheme exception and throw it.
455 This function does not return. */
458 gdbscm_throw_gdb_exception (struct gdb_exception exception
)
460 gdbscm_throw (gdbscm_scm_from_gdb_exception (exception
));
463 /* Print the error message portion of an exception.
464 If PORT is #f, use the standard error port.
465 KEY cannot be gdb:with-stack.
467 Basically this function is just a wrapper around calling
468 %print-exception-message. */
471 gdbscm_print_exception_message (SCM port
, SCM frame
, SCM key
, SCM args
)
475 if (gdbscm_is_false (port
))
476 port
= scm_current_error_port ();
478 gdb_assert (!scm_is_eq (key
, with_stack_error_symbol
));
480 /* This does not use scm_print_exception because we tweak the output a bit.
481 Compare Guile's print-exception with our %print-exception-message for
483 if (gdbscm_is_false (percent_print_exception_message_var
))
485 percent_print_exception_message_var
486 = scm_c_private_variable (gdbscm_init_module_name
,
487 percent_print_exception_message_name
);
488 /* If we can't find %print-exception-message, there's a problem on the
489 Scheme side. Don't kill GDB, just flag an error and leave it at
491 if (gdbscm_is_false (percent_print_exception_message_var
))
493 gdbscm_printf (port
, _("Error in Scheme exception printing,"
494 " can't find %s.\n"),
495 percent_print_exception_message_name
);
499 printer
= scm_variable_ref (percent_print_exception_message_var
);
501 status
= gdbscm_safe_call_4 (printer
, port
, frame
, key
, args
, NULL
);
503 /* If that failed still tell the user something.
504 But don't use the exception printing machinery! */
505 if (gdbscm_is_exception (status
))
507 gdbscm_printf (port
, _("Error in Scheme exception printing:\n"));
508 scm_display (status
, port
);
513 /* Print the description of exception KEY, ARGS to PORT, according to the
514 setting of "set guile print-stack".
515 If PORT is #f, use the standard error port.
516 If STACK is #f, never print the stack, regardless of whether printing it
517 is enabled. If STACK is #t, then print it if it is contained in ARGS
518 (i.e., KEY is gdb:with-stack). Otherwise STACK is the result of calling
519 scm_make_stack (which will be ignored in favor of the stack in ARGS if
520 KEY is gdb:with-stack).
521 KEY, ARGS are the standard arguments to scm_throw, et.al.
523 Basically this function is just a wrapper around calling
524 %print-exception-with-args. */
527 gdbscm_print_exception_with_stack (SCM port
, SCM stack
, SCM key
, SCM args
)
531 if (gdbscm_is_false (port
))
532 port
= scm_current_error_port ();
534 if (gdbscm_is_false (percent_print_exception_with_stack_var
))
536 percent_print_exception_with_stack_var
537 = scm_c_private_variable (gdbscm_init_module_name
,
538 percent_print_exception_with_stack_name
);
539 /* If we can't find %print-exception-with-args, there's a problem on the
540 Scheme side. Don't kill GDB, just flag an error and leave it at
542 if (gdbscm_is_false (percent_print_exception_with_stack_var
))
544 gdbscm_printf (port
, _("Error in Scheme exception printing,"
545 " can't find %s.\n"),
546 percent_print_exception_with_stack_name
);
550 printer
= scm_variable_ref (percent_print_exception_with_stack_var
);
552 status
= gdbscm_safe_call_4 (printer
, port
, stack
, key
, args
, NULL
);
554 /* If that failed still tell the user something.
555 But don't use the exception printing machinery! */
556 if (gdbscm_is_exception (status
))
558 gdbscm_printf (port
, _("Error in Scheme exception printing:\n"));
559 scm_display (status
, port
);
564 /* Print EXCEPTION, a <gdb:exception> object, to PORT.
565 If PORT is #f, use the standard error port. */
568 gdbscm_print_gdb_exception (SCM port
, SCM exception
)
570 gdb_assert (gdbscm_is_exception (exception
));
572 gdbscm_print_exception_with_stack (port
, SCM_BOOL_T
,
573 gdbscm_exception_key (exception
),
574 gdbscm_exception_args (exception
));
577 /* Return a string description of <gdb:exception> EXCEPTION.
578 If EXCEPTION is a gdb:with-stack exception, unwrap it, a backtrace
579 is never returned as part of the result.
581 Space for the result is malloc'd, the caller must free. */
584 gdbscm_exception_message_to_string (SCM exception
)
586 SCM port
= scm_open_output_string ();
590 gdb_assert (gdbscm_is_exception (exception
));
592 key
= gdbscm_exception_key (exception
);
593 args
= gdbscm_exception_args (exception
);
595 if (scm_is_eq (key
, with_stack_error_symbol
)
596 /* Don't crash on a badly generated gdb:with-stack exception. */
597 && scm_is_pair (args
)
598 && scm_is_pair (scm_cdr (args
)))
600 key
= scm_car (args
);
601 args
= scm_cddr (args
);
604 gdbscm_print_exception_message (port
, SCM_BOOL_F
, key
, args
);
605 result
= gdbscm_scm_to_c_string (scm_get_output_string (port
));
606 scm_close_port (port
);
611 /* Return the value of the "guile print-stack" option as one of:
612 'none, 'message, 'full. */
615 gdbscm_percent_exception_print_style (void)
617 if (gdbscm_print_excp
== gdbscm_print_excp_none
)
619 if (gdbscm_print_excp
== gdbscm_print_excp_message
)
620 return message_symbol
;
621 if (gdbscm_print_excp
== gdbscm_print_excp_full
)
623 gdb_assert_not_reached ("bad value for \"guile print-stack\"");
626 /* Return the current <gdb:exception> counter.
627 This is for debugging purposes. */
630 gdbscm_percent_exception_count (void)
632 return scm_from_ulong (gdbscm_exception_count
);
635 /* Initialize the Scheme exception support. */
637 static const scheme_function exception_functions
[] =
639 { "make-exception", 2, 0, 0, gdbscm_make_exception
,
641 Create a <gdb:exception> object.\n\
643 Arguments: key args\n\
644 These are the standard key,args arguments of \"throw\"." },
646 { "exception?", 1, 0, 0, gdbscm_exception_p
,
648 Return #t if the object is a <gdb:exception> object." },
650 { "exception-key", 1, 0, 0, gdbscm_exception_key
,
652 Return the exception's key." },
654 { "exception-args", 1, 0, 0, gdbscm_exception_args
,
656 Return the exception's arg list." },
661 static const scheme_function private_exception_functions
[] =
663 { "%exception-print-style", 0, 0, 0, gdbscm_percent_exception_print_style
,
665 Return the value of the \"guile print-stack\" option." },
667 { "%exception-count", 0, 0, 0, gdbscm_percent_exception_count
,
669 Return a count of the number of <gdb:exception> objects created.\n\
670 This is for debugging purposes." },
676 gdbscm_initialize_exceptions (void)
678 exception_smob_tag
= gdbscm_make_smob_type (exception_smob_name
,
679 sizeof (exception_smob
));
680 scm_set_smob_print (exception_smob_tag
, exscm_print_exception_smob
);
682 gdbscm_define_functions (exception_functions
, 1);
683 gdbscm_define_functions (private_exception_functions
, 0);
685 error_symbol
= scm_from_latin1_symbol ("gdb:error");
687 memory_error_symbol
= scm_from_latin1_symbol ("gdb:memory-error");
689 user_error_symbol
= scm_from_latin1_symbol ("gdb:user-error");
691 gdbscm_invalid_object_error_symbol
692 = scm_from_latin1_symbol ("gdb:invalid-object-error");
694 with_stack_error_symbol
= scm_from_latin1_symbol ("gdb:with-stack");
696 /* The text of this symbol is taken from Guile's top-repl.scm. */
697 signal_symbol
= scm_from_latin1_symbol ("signal");
699 none_symbol
= scm_from_latin1_symbol ("none");
700 message_symbol
= scm_from_latin1_symbol ("message");
701 full_symbol
= scm_from_latin1_symbol ("full");