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 /* Printing the stack is done by first capturing the stack and recording it in
68 a <gdb:exception> object with this key and with the ARGS field set to
69 (cons real-key (cons stack real-args)).
70 See gdbscm_make_exception_with_stack. */
71 static SCM with_stack_error_symbol
;
73 /* The key to use for an invalid object exception. An invalid object is one
74 where the underlying object has been removed from GDB. */
75 SCM gdbscm_invalid_object_error_symbol
;
77 /* Values for "guile print-stack" as symbols. */
78 static SCM none_symbol
;
79 static SCM message_symbol
;
80 static SCM full_symbol
;
82 static const char percent_print_exception_message_name
[] =
83 "%print-exception-message";
85 /* Variable containing %print-exception-message.
86 It is not defined until late in initialization, after our init routine
87 has run. Cope by looking it up lazily. */
88 static SCM percent_print_exception_message_var
= SCM_BOOL_F
;
90 static const char percent_print_exception_with_stack_name
[] =
91 "%print-exception-with-stack";
93 /* Variable containing %print-exception-with-stack.
94 It is not defined until late in initialization, after our init routine
95 has run. Cope by looking it up lazily. */
96 static SCM percent_print_exception_with_stack_var
= SCM_BOOL_F
;
98 /* Counter to keep track of the number of times we create a <gdb:exception>
99 object, for performance monitoring purposes. */
100 static unsigned long gdbscm_exception_count
= 0;
102 /* Administrivia for exception smobs. */
104 /* The smob "mark" function for <gdb:exception>. */
107 exscm_mark_exception_smob (SCM self
)
109 exception_smob
*e_smob
= (exception_smob
*) SCM_SMOB_DATA (self
);
111 scm_gc_mark (e_smob
->key
);
112 scm_gc_mark (e_smob
->args
);
114 return gdbscm_mark_gsmob (&e_smob
->base
);
117 /* The smob "print" function for <gdb:exception>. */
120 exscm_print_exception_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
122 exception_smob
*e_smob
= (exception_smob
*) SCM_SMOB_DATA (self
);
124 gdbscm_printf (port
, "#<%s ", exception_smob_name
);
125 scm_write (e_smob
->key
, port
);
126 scm_puts (" ", port
);
127 scm_write (e_smob
->args
, port
);
128 scm_puts (">", port
);
130 scm_remember_upto_here_1 (self
);
132 /* Non-zero means success. */
136 /* (make-exception key args) -> <gdb:exception> */
139 gdbscm_make_exception (SCM key
, SCM args
)
141 exception_smob
*e_smob
= (exception_smob
*)
142 scm_gc_malloc (sizeof (exception_smob
), exception_smob_name
);
147 smob
= scm_new_smob (exception_smob_tag
, (scm_t_bits
) e_smob
);
148 gdbscm_init_gsmob (&e_smob
->base
);
150 ++gdbscm_exception_count
;
155 /* Return non-zero if SCM is a <gdb:exception> object. */
158 gdbscm_is_exception (SCM scm
)
160 return SCM_SMOB_PREDICATE (exception_smob_tag
, scm
);
163 /* (exception? scm) -> boolean */
166 gdbscm_exception_p (SCM scm
)
168 return scm_from_bool (gdbscm_is_exception (scm
));
171 /* (exception-key <gdb:exception>) -> key */
174 gdbscm_exception_key (SCM self
)
176 exception_smob
*e_smob
;
178 SCM_ASSERT_TYPE (gdbscm_is_exception (self
), self
, SCM_ARG1
, FUNC_NAME
,
181 e_smob
= (exception_smob
*) SCM_SMOB_DATA (self
);
185 /* (exception-args <gdb:exception>) -> arg-list */
188 gdbscm_exception_args (SCM self
)
190 exception_smob
*e_smob
;
192 SCM_ASSERT_TYPE (gdbscm_is_exception (self
), self
, SCM_ARG1
, FUNC_NAME
,
195 e_smob
= (exception_smob
*) SCM_SMOB_DATA (self
);
199 /* Wrap an exception in a <gdb:exception> object that includes STACK.
200 gdbscm_print_exception_with_stack knows how to unwrap it. */
203 gdbscm_make_exception_with_stack (SCM key
, SCM args
, SCM stack
)
205 return gdbscm_make_exception (with_stack_error_symbol
,
206 scm_cons (key
, scm_cons (stack
, args
)));
209 /* Version of scm_error_scm that creates a gdb:exception object that can later
210 be passed to gdbscm_throw.
211 KEY is a symbol denoting the kind of error.
212 SUBR is either #f or a string marking the function in which the error
214 MESSAGE is either #f or the error message string. It may contain ~a and ~s
215 modifiers, provided by ARGS.
216 ARGS is a list of args to MESSAGE.
217 DATA is an arbitrary object, its value depends on KEY. The value to pass
218 here is a bit underspecified by Guile. */
221 gdbscm_make_error_scm (SCM key
, SCM subr
, SCM message
, SCM args
, SCM data
)
223 return gdbscm_make_exception (key
, scm_list_4 (subr
, message
, args
, data
));
226 /* Version of scm_error that creates a gdb:exception object that can later
227 be passed to gdbscm_throw.
228 See gdbscm_make_error_scm for a description of the arguments. */
231 gdbscm_make_error (SCM key
, const char *subr
, const char *message
,
234 return gdbscm_make_error_scm
236 subr
== NULL
? SCM_BOOL_F
: scm_from_latin1_string (subr
),
237 message
== NULL
? SCM_BOOL_F
: scm_from_latin1_string (message
),
241 /* Version of SCM_ASSERT_TYPE/scm_wrong_type_arg_msg that creates a
242 gdb:exception object that can later be passed to gdbscm_throw. */
245 gdbscm_make_type_error (const char *subr
, int arg_pos
, SCM bad_value
,
246 const char *expected_type
)
253 if (expected_type
!= NULL
)
255 msg
= xstrprintf (_("Wrong type argument in position %d"
256 " (expecting %s): ~S"),
257 arg_pos
, expected_type
);
261 msg
= xstrprintf (_("Wrong type argument in position %d: ~S"),
267 if (expected_type
!= NULL
)
269 msg
= xstrprintf (_("Wrong type argument (expecting %s): ~S"),
273 msg
= xstrprintf (_("Wrong type argument: ~S"));
276 result
= gdbscm_make_error (scm_arg_type_key
, subr
, msg
,
277 scm_list_1 (bad_value
), scm_list_1 (bad_value
));
282 /* A variant of gdbscm_make_type_error for non-type argument errors.
283 ERROR_PREFIX and ERROR are combined to build the error message.
284 Care needs to be taken so that the i18n composed form is still
285 reasonable, but no one is going to translate these anyway so we don't
287 ERROR_PREFIX may be NULL, ERROR may not be NULL. */
290 gdbscm_make_arg_error (SCM key
, const char *subr
, int arg_pos
, SCM bad_value
,
291 const char *error_prefix
, const char *error
)
296 if (error_prefix
!= NULL
)
300 msg
= xstrprintf (_("%s %s in position %d: ~S"),
301 error_prefix
, error
, arg_pos
);
304 msg
= xstrprintf (_("%s %s: ~S"), error_prefix
, error
);
309 msg
= xstrprintf (_("%s in position %d: ~S"), error
, arg_pos
);
311 msg
= xstrprintf (_("%s: ~S"), error
);
314 result
= gdbscm_make_error (key
, subr
, msg
,
315 scm_list_1 (bad_value
), scm_list_1 (bad_value
));
320 /* Make an invalid-object error <gdb:exception> object.
321 OBJECT is the name of the kind of object that is invalid. */
324 gdbscm_make_invalid_object_error (const char *subr
, int arg_pos
, SCM bad_value
,
327 return gdbscm_make_arg_error (gdbscm_invalid_object_error_symbol
,
328 subr
, arg_pos
, bad_value
,
329 _("Invalid object:"), object
);
332 /* Throw an invalid-object error.
333 OBJECT is the name of the kind of object that is invalid. */
336 gdbscm_invalid_object_error (const char *subr
, int arg_pos
, SCM bad_value
,
340 = gdbscm_make_invalid_object_error (subr
, arg_pos
, bad_value
, object
);
342 gdbscm_throw (exception
);
345 /* Make an out-of-range error <gdb:exception> object. */
348 gdbscm_make_out_of_range_error (const char *subr
, int arg_pos
, SCM bad_value
,
351 return gdbscm_make_arg_error (scm_out_of_range_key
,
352 subr
, arg_pos
, bad_value
,
353 _("Out of range:"), error
);
356 /* Throw an out-of-range error.
357 This is the standard Guile out-of-range exception. */
360 gdbscm_out_of_range_error (const char *subr
, int arg_pos
, SCM bad_value
,
364 = gdbscm_make_out_of_range_error (subr
, arg_pos
, bad_value
, error
);
366 gdbscm_throw (exception
);
369 /* Make a misc-error <gdb:exception> object. */
372 gdbscm_make_misc_error (const char *subr
, int arg_pos
, SCM bad_value
,
375 return gdbscm_make_arg_error (scm_misc_error_key
,
376 subr
, arg_pos
, bad_value
, NULL
, error
);
379 /* Return a <gdb:exception> object for gdb:memory-error. */
382 gdbscm_make_memory_error (const char *subr
, const char *msg
, SCM args
)
384 return gdbscm_make_error (memory_error_symbol
, subr
, msg
, args
,
388 /* Throw a gdb:memory-error exception. */
391 gdbscm_memory_error (const char *subr
, const char *msg
, SCM args
)
393 SCM exception
= gdbscm_make_memory_error (subr
, msg
, args
);
395 gdbscm_throw (exception
);
398 /* Return non-zero if KEY is gdb:memory-error.
399 Note: This is an excp_matcher_func function. */
402 gdbscm_memory_error_p (SCM key
)
404 return scm_is_eq (key
, memory_error_symbol
);
407 /* Wrapper around scm_throw to throw a gdb:exception.
408 This function does not return.
409 This function cannot be called from inside TRY_CATCH. */
412 gdbscm_throw (SCM exception
)
414 scm_throw (gdbscm_exception_key (exception
),
415 gdbscm_exception_args (exception
));
416 gdb_assert_not_reached ("scm_throw returned");
419 /* Convert a GDB exception to a <gdb:exception> object. */
422 gdbscm_scm_from_gdb_exception (struct gdb_exception exception
)
426 if (exception
.reason
== RETURN_QUIT
)
428 /* Handle this specially to be consistent with top-repl.scm. */
429 return gdbscm_make_error (signal_symbol
, NULL
, _("User interrupt"),
430 SCM_EOL
, scm_list_1 (scm_from_int (SIGINT
)));
433 if (exception
.error
== MEMORY_ERROR
)
434 key
= memory_error_symbol
;
438 return gdbscm_make_error (key
, NULL
, "~A",
439 scm_list_1 (gdbscm_scm_from_c_string
440 (exception
.message
)),
444 /* Convert a GDB exception to the appropriate Scheme exception and throw it.
445 This function does not return. */
448 gdbscm_throw_gdb_exception (struct gdb_exception exception
)
450 gdbscm_throw (gdbscm_scm_from_gdb_exception (exception
));
453 /* Print the error message portion of an exception.
454 If PORT is #f, use the standard error port.
455 KEY cannot be gdb:with-stack.
457 Basically this function is just a wrapper around calling
458 %print-exception-message. */
461 gdbscm_print_exception_message (SCM port
, SCM frame
, SCM key
, SCM args
)
465 if (gdbscm_is_false (port
))
466 port
= scm_current_error_port ();
468 gdb_assert (!scm_is_eq (key
, with_stack_error_symbol
));
470 /* This does not use scm_print_exception because we tweak the output a bit.
471 Compare Guile's print-exception with our %print-exception-message for
473 if (gdbscm_is_false (percent_print_exception_message_var
))
475 percent_print_exception_message_var
476 = scm_c_private_variable (gdbscm_init_module_name
,
477 percent_print_exception_message_name
);
478 /* If we can't find %print-exception-message, there's a problem on the
479 Scheme side. Don't kill GDB, just flag an error and leave it at
481 if (gdbscm_is_false (percent_print_exception_message_var
))
483 gdbscm_printf (port
, _("Error in Scheme exception printing,"
484 " can't find %s.\n"),
485 percent_print_exception_message_name
);
489 printer
= scm_variable_ref (percent_print_exception_message_var
);
491 status
= gdbscm_safe_call_4 (printer
, port
, frame
, key
, args
, NULL
);
493 /* If that failed still tell the user something.
494 But don't use the exception printing machinery! */
495 if (gdbscm_is_exception (status
))
497 gdbscm_printf (port
, _("Error in Scheme exception printing:\n"));
498 scm_display (status
, port
);
503 /* Print the description of exception KEY, ARGS to PORT, according to the
504 setting of "set guile print-stack".
505 If PORT is #f, use the standard error port.
506 If STACK is #f, never print the stack, regardless of whether printing it
507 is enabled. If STACK is #t, then print it if it is contained in ARGS
508 (i.e., KEY is gdb:with-stack). Otherwise STACK is the result of calling
509 scm_make_stack (which will be ignored in favor of the stack in ARGS if
510 KEY is gdb:with-stack).
511 KEY, ARGS are the standard arguments to scm_throw, et.al.
513 Basically this function is just a wrapper around calling
514 %print-exception-with-args. */
517 gdbscm_print_exception_with_stack (SCM port
, SCM stack
, SCM key
, SCM args
)
521 if (gdbscm_is_false (port
))
522 port
= scm_current_error_port ();
524 if (gdbscm_is_false (percent_print_exception_with_stack_var
))
526 percent_print_exception_with_stack_var
527 = scm_c_private_variable (gdbscm_init_module_name
,
528 percent_print_exception_with_stack_name
);
529 /* If we can't find %print-exception-with-args, there's a problem on the
530 Scheme side. Don't kill GDB, just flag an error and leave it at
532 if (gdbscm_is_false (percent_print_exception_with_stack_var
))
534 gdbscm_printf (port
, _("Error in Scheme exception printing,"
535 " can't find %s.\n"),
536 percent_print_exception_with_stack_name
);
540 printer
= scm_variable_ref (percent_print_exception_with_stack_var
);
542 status
= gdbscm_safe_call_4 (printer
, port
, stack
, key
, args
, NULL
);
544 /* If that failed still tell the user something.
545 But don't use the exception printing machinery! */
546 if (gdbscm_is_exception (status
))
548 gdbscm_printf (port
, _("Error in Scheme exception printing:\n"));
549 scm_display (status
, port
);
554 /* Print EXCEPTION, a <gdb:exception> object, to PORT.
555 If PORT is #f, use the standard error port. */
558 gdbscm_print_gdb_exception (SCM port
, SCM exception
)
560 gdb_assert (gdbscm_is_exception (exception
));
562 gdbscm_print_exception_with_stack (port
, SCM_BOOL_T
,
563 gdbscm_exception_key (exception
),
564 gdbscm_exception_args (exception
));
567 /* Return a string description of <gdb:exception> EXCEPTION.
568 If EXCEPTION is a gdb:with-stack exception, unwrap it, a backtrace
569 is never returned as part of the result.
571 Space for the result is malloc'd, the caller must free. */
574 gdbscm_exception_message_to_string (SCM exception
)
576 SCM port
= scm_open_output_string ();
580 gdb_assert (gdbscm_is_exception (exception
));
582 key
= gdbscm_exception_key (exception
);
583 args
= gdbscm_exception_args (exception
);
585 if (scm_is_eq (key
, with_stack_error_symbol
)
586 /* Don't crash on a badly generated gdb:with-stack exception. */
587 && scm_is_pair (args
)
588 && scm_is_pair (scm_cdr (args
)))
590 key
= scm_car (args
);
591 args
= scm_cddr (args
);
594 gdbscm_print_exception_message (port
, SCM_BOOL_F
, key
, args
);
595 result
= gdbscm_scm_to_c_string (scm_get_output_string (port
));
596 scm_close_port (port
);
601 /* Return the value of the "guile print-stack" option as one of:
602 'none, 'message, 'full. */
605 gdbscm_percent_exception_print_style (void)
607 if (gdbscm_print_excp
== gdbscm_print_excp_none
)
609 if (gdbscm_print_excp
== gdbscm_print_excp_message
)
610 return message_symbol
;
611 if (gdbscm_print_excp
== gdbscm_print_excp_full
)
613 gdb_assert_not_reached ("bad value for \"guile print-stack\"");
616 /* Return the current <gdb:exception> counter.
617 This is for debugging purposes. */
620 gdbscm_percent_exception_count (void)
622 return scm_from_ulong (gdbscm_exception_count
);
625 /* Initialize the Scheme exception support. */
627 static const scheme_function exception_functions
[] =
629 { "make-exception", 2, 0, 0, gdbscm_make_exception
,
631 Create a <gdb:exception> object.\n\
633 Arguments: key args\n\
634 These are the standard key,args arguments of \"throw\"." },
636 { "exception?", 1, 0, 0, gdbscm_exception_p
,
638 Return #t if the object is a <gdb:exception> object." },
640 { "exception-key", 1, 0, 0, gdbscm_exception_key
,
642 Return the exception's key." },
644 { "exception-args", 1, 0, 0, gdbscm_exception_args
,
646 Return the exception's arg list." },
651 static const scheme_function private_exception_functions
[] =
653 { "%exception-print-style", 0, 0, 0, gdbscm_percent_exception_print_style
,
655 Return the value of the \"guile print-stack\" option." },
657 { "%exception-count", 0, 0, 0, gdbscm_percent_exception_count
,
659 Return a count of the number of <gdb:exception> objects created.\n\
660 This is for debugging purposes." },
666 gdbscm_initialize_exceptions (void)
668 exception_smob_tag
= gdbscm_make_smob_type (exception_smob_name
,
669 sizeof (exception_smob
));
670 scm_set_smob_mark (exception_smob_tag
, exscm_mark_exception_smob
);
671 scm_set_smob_print (exception_smob_tag
, exscm_print_exception_smob
);
673 gdbscm_define_functions (exception_functions
, 1);
674 gdbscm_define_functions (private_exception_functions
, 0);
676 error_symbol
= scm_from_latin1_symbol ("gdb:error");
678 memory_error_symbol
= scm_from_latin1_symbol ("gdb:memory-error");
680 gdbscm_invalid_object_error_symbol
681 = scm_from_latin1_symbol ("gdb:invalid-object-error");
683 with_stack_error_symbol
= scm_from_latin1_symbol ("gdb:with-stack");
685 /* The text of this symbol is taken from Guile's top-repl.scm. */
686 signal_symbol
= scm_from_latin1_symbol ("signal");
688 none_symbol
= scm_from_latin1_symbol ("none");
689 message_symbol
= scm_from_latin1_symbol ("message");
690 full_symbol
= scm_from_latin1_symbol ("full");