1 /* GDB/Scheme exception support.
3 Copyright (C) 2014-2019 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 "guile-internal.h"
35 /* The <gdb:exception> smob.
36 This is used to record and handle Scheme exceptions.
37 One important invariant is that <gdb:exception> smobs are never a valid
38 result of a function, other than to signify an exception occurred. */
42 /* This always appears first. */
45 /* The key and args parameters to "throw". */
50 static const char exception_smob_name
[] = "gdb:exception";
52 /* The tag Guile knows the exception smob by. */
53 static scm_t_bits exception_smob_tag
;
55 /* A generic error in struct gdb_exception.
56 I.e., not RETURN_QUIT and not MEMORY_ERROR. */
57 static SCM error_symbol
;
59 /* An error occurred accessing inferior memory.
60 This is not a Scheme programming error. */
61 static SCM memory_error_symbol
;
63 /* User interrupt, e.g., RETURN_QUIT in struct gdb_exception. */
64 static SCM signal_symbol
;
66 /* A user error, e.g., bad arg to gdb command. */
67 static SCM user_error_symbol
;
69 /* Printing the stack is done by first capturing the stack and recording it in
70 a <gdb:exception> object with this key and with the ARGS field set to
71 (cons real-key (cons stack real-args)).
72 See gdbscm_make_exception_with_stack. */
73 static SCM with_stack_error_symbol
;
75 /* The key to use for an invalid object exception. An invalid object is one
76 where the underlying object has been removed from GDB. */
77 SCM gdbscm_invalid_object_error_symbol
;
79 /* Values for "guile print-stack" as symbols. */
80 static SCM none_symbol
;
81 static SCM message_symbol
;
82 static SCM full_symbol
;
84 static const char percent_print_exception_message_name
[] =
85 "%print-exception-message";
87 /* Variable containing %print-exception-message.
88 It is not defined until late in initialization, after our init routine
89 has run. Cope by looking it up lazily. */
90 static SCM percent_print_exception_message_var
= SCM_BOOL_F
;
92 static const char percent_print_exception_with_stack_name
[] =
93 "%print-exception-with-stack";
95 /* Variable containing %print-exception-with-stack.
96 It is not defined until late in initialization, after our init routine
97 has run. Cope by looking it up lazily. */
98 static SCM percent_print_exception_with_stack_var
= SCM_BOOL_F
;
100 /* Counter to keep track of the number of times we create a <gdb:exception>
101 object, for performance monitoring purposes. */
102 static unsigned long gdbscm_exception_count
= 0;
104 /* Administrivia for exception smobs. */
106 /* The smob "print" function for <gdb:exception>. */
109 exscm_print_exception_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
111 exception_smob
*e_smob
= (exception_smob
*) SCM_SMOB_DATA (self
);
113 gdbscm_printf (port
, "#<%s ", exception_smob_name
);
114 scm_write (e_smob
->key
, port
);
115 scm_puts (" ", port
);
116 scm_write (e_smob
->args
, port
);
117 scm_puts (">", port
);
119 scm_remember_upto_here_1 (self
);
121 /* Non-zero means success. */
125 /* (make-exception key args) -> <gdb:exception> */
128 gdbscm_make_exception (SCM key
, SCM args
)
130 exception_smob
*e_smob
= (exception_smob
*)
131 scm_gc_malloc (sizeof (exception_smob
), exception_smob_name
);
136 smob
= scm_new_smob (exception_smob_tag
, (scm_t_bits
) e_smob
);
137 gdbscm_init_gsmob (&e_smob
->base
);
139 ++gdbscm_exception_count
;
144 /* Return non-zero if SCM is a <gdb:exception> object. */
147 gdbscm_is_exception (SCM scm
)
149 return SCM_SMOB_PREDICATE (exception_smob_tag
, scm
);
152 /* (exception? scm) -> boolean */
155 gdbscm_exception_p (SCM scm
)
157 return scm_from_bool (gdbscm_is_exception (scm
));
160 /* (exception-key <gdb:exception>) -> key */
163 gdbscm_exception_key (SCM self
)
165 exception_smob
*e_smob
;
167 SCM_ASSERT_TYPE (gdbscm_is_exception (self
), self
, SCM_ARG1
, FUNC_NAME
,
170 e_smob
= (exception_smob
*) SCM_SMOB_DATA (self
);
174 /* (exception-args <gdb:exception>) -> arg-list */
177 gdbscm_exception_args (SCM self
)
179 exception_smob
*e_smob
;
181 SCM_ASSERT_TYPE (gdbscm_is_exception (self
), self
, SCM_ARG1
, FUNC_NAME
,
184 e_smob
= (exception_smob
*) SCM_SMOB_DATA (self
);
188 /* Wrap an exception in a <gdb:exception> object that includes STACK.
189 gdbscm_print_exception_with_stack knows how to unwrap it. */
192 gdbscm_make_exception_with_stack (SCM key
, SCM args
, SCM stack
)
194 return gdbscm_make_exception (with_stack_error_symbol
,
195 scm_cons (key
, scm_cons (stack
, args
)));
198 /* Version of scm_error_scm that creates a gdb:exception object that can later
199 be passed to gdbscm_throw.
200 KEY is a symbol denoting the kind of error.
201 SUBR is either #f or a string marking the function in which the error
203 MESSAGE is either #f or the error message string. It may contain ~a and ~s
204 modifiers, provided by ARGS.
205 ARGS is a list of args to MESSAGE.
206 DATA is an arbitrary object, its value depends on KEY. The value to pass
207 here is a bit underspecified by Guile. */
210 gdbscm_make_error_scm (SCM key
, SCM subr
, SCM message
, SCM args
, SCM data
)
212 return gdbscm_make_exception (key
, scm_list_4 (subr
, message
, args
, data
));
215 /* Version of scm_error that creates a gdb:exception object that can later
216 be passed to gdbscm_throw.
217 See gdbscm_make_error_scm for a description of the arguments. */
220 gdbscm_make_error (SCM key
, const char *subr
, const char *message
,
223 return gdbscm_make_error_scm
225 subr
== NULL
? SCM_BOOL_F
: scm_from_latin1_string (subr
),
226 message
== NULL
? SCM_BOOL_F
: scm_from_latin1_string (message
),
230 /* Version of SCM_ASSERT_TYPE/scm_wrong_type_arg_msg that creates a
231 gdb:exception object that can later be passed to gdbscm_throw. */
234 gdbscm_make_type_error (const char *subr
, int arg_pos
, SCM bad_value
,
235 const char *expected_type
)
242 if (expected_type
!= NULL
)
244 msg
= xstrprintf (_("Wrong type argument in position %d"
245 " (expecting %s): ~S"),
246 arg_pos
, expected_type
);
250 msg
= xstrprintf (_("Wrong type argument in position %d: ~S"),
256 if (expected_type
!= NULL
)
258 msg
= xstrprintf (_("Wrong type argument (expecting %s): ~S"),
262 msg
= xstrprintf (_("Wrong type argument: ~S"));
265 result
= gdbscm_make_error (scm_arg_type_key
, subr
, msg
,
266 scm_list_1 (bad_value
), scm_list_1 (bad_value
));
271 /* A variant of gdbscm_make_type_error for non-type argument errors.
272 ERROR_PREFIX and ERROR are combined to build the error message.
273 Care needs to be taken so that the i18n composed form is still
274 reasonable, but no one is going to translate these anyway so we don't
276 ERROR_PREFIX may be NULL, ERROR may not be NULL. */
279 gdbscm_make_arg_error (SCM key
, const char *subr
, int arg_pos
, SCM bad_value
,
280 const char *error_prefix
, const char *error
)
285 if (error_prefix
!= NULL
)
289 msg
= xstrprintf (_("%s %s in position %d: ~S"),
290 error_prefix
, error
, arg_pos
);
293 msg
= xstrprintf (_("%s %s: ~S"), error_prefix
, error
);
298 msg
= xstrprintf (_("%s in position %d: ~S"), error
, arg_pos
);
300 msg
= xstrprintf (_("%s: ~S"), error
);
303 result
= gdbscm_make_error (key
, subr
, msg
,
304 scm_list_1 (bad_value
), scm_list_1 (bad_value
));
309 /* Make an invalid-object error <gdb:exception> object.
310 OBJECT is the name of the kind of object that is invalid. */
313 gdbscm_make_invalid_object_error (const char *subr
, int arg_pos
, SCM bad_value
,
316 return gdbscm_make_arg_error (gdbscm_invalid_object_error_symbol
,
317 subr
, arg_pos
, bad_value
,
318 _("Invalid object:"), object
);
321 /* Throw an invalid-object error.
322 OBJECT is the name of the kind of object that is invalid. */
325 gdbscm_invalid_object_error (const char *subr
, int arg_pos
, SCM bad_value
,
329 = gdbscm_make_invalid_object_error (subr
, arg_pos
, bad_value
, object
);
331 gdbscm_throw (exception
);
334 /* Make an out-of-range error <gdb:exception> object. */
337 gdbscm_make_out_of_range_error (const char *subr
, int arg_pos
, SCM bad_value
,
340 return gdbscm_make_arg_error (scm_out_of_range_key
,
341 subr
, arg_pos
, bad_value
,
342 _("Out of range:"), error
);
345 /* Throw an out-of-range error.
346 This is the standard Guile out-of-range exception. */
349 gdbscm_out_of_range_error (const char *subr
, int arg_pos
, SCM bad_value
,
353 = gdbscm_make_out_of_range_error (subr
, arg_pos
, bad_value
, error
);
355 gdbscm_throw (exception
);
358 /* Make a misc-error <gdb:exception> object. */
361 gdbscm_make_misc_error (const char *subr
, int arg_pos
, SCM bad_value
,
364 return gdbscm_make_arg_error (scm_misc_error_key
,
365 subr
, arg_pos
, bad_value
, NULL
, error
);
368 /* Throw a misc-error error. */
371 gdbscm_misc_error (const char *subr
, int arg_pos
, SCM bad_value
,
374 SCM exception
= gdbscm_make_misc_error (subr
, arg_pos
, bad_value
, error
);
376 gdbscm_throw (exception
);
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 /* Return non-zero if KEY is gdb:user-error.
408 Note: This is an excp_matcher_func function. */
411 gdbscm_user_error_p (SCM key
)
413 return scm_is_eq (key
, user_error_symbol
);
416 /* Wrapper around scm_throw to throw a gdb:exception.
417 This function does not return.
418 This function cannot be called from inside TRY_CATCH. */
421 gdbscm_throw (SCM exception
)
423 scm_throw (gdbscm_exception_key (exception
),
424 gdbscm_exception_args (exception
));
425 gdb_assert_not_reached ("scm_throw returned");
428 /* Convert a GDB exception to a <gdb:exception> object. */
431 gdbscm_scm_from_gdb_exception (const gdbscm_gdb_exception
&exception
)
435 if (exception
.reason
== RETURN_QUIT
)
437 /* Handle this specially to be consistent with top-repl.scm. */
438 return gdbscm_make_error (signal_symbol
, NULL
, _("User interrupt"),
439 SCM_EOL
, scm_list_1 (scm_from_int (SIGINT
)));
442 if (exception
.error
== MEMORY_ERROR
)
443 key
= memory_error_symbol
;
447 return gdbscm_make_error (key
, NULL
, "~A",
448 scm_list_1 (gdbscm_scm_from_c_string
449 (exception
.message
)),
453 /* Convert a GDB exception to the appropriate Scheme exception and throw it.
454 This function does not return. */
457 gdbscm_throw_gdb_exception (gdbscm_gdb_exception exception
)
459 SCM scm_exception
= gdbscm_scm_from_gdb_exception (exception
);
460 xfree (exception
.message
);
461 gdbscm_throw (scm_exception
);
464 /* Print the error message portion of an exception.
465 If PORT is #f, use the standard error port.
466 KEY cannot be gdb:with-stack.
468 Basically this function is just a wrapper around calling
469 %print-exception-message. */
472 gdbscm_print_exception_message (SCM port
, SCM frame
, SCM key
, SCM args
)
476 if (gdbscm_is_false (port
))
477 port
= scm_current_error_port ();
479 gdb_assert (!scm_is_eq (key
, with_stack_error_symbol
));
481 /* This does not use scm_print_exception because we tweak the output a bit.
482 Compare Guile's print-exception with our %print-exception-message for
484 if (gdbscm_is_false (percent_print_exception_message_var
))
486 percent_print_exception_message_var
487 = scm_c_private_variable (gdbscm_init_module_name
,
488 percent_print_exception_message_name
);
489 /* If we can't find %print-exception-message, there's a problem on the
490 Scheme side. Don't kill GDB, just flag an error and leave it at
492 if (gdbscm_is_false (percent_print_exception_message_var
))
494 gdbscm_printf (port
, _("Error in Scheme exception printing,"
495 " can't find %s.\n"),
496 percent_print_exception_message_name
);
500 printer
= scm_variable_ref (percent_print_exception_message_var
);
502 status
= gdbscm_safe_call_4 (printer
, port
, frame
, key
, args
, NULL
);
504 /* If that failed still tell the user something.
505 But don't use the exception printing machinery! */
506 if (gdbscm_is_exception (status
))
508 gdbscm_printf (port
, _("Error in Scheme exception printing:\n"));
509 scm_display (status
, port
);
514 /* Print the description of exception KEY, ARGS to PORT, according to the
515 setting of "set guile print-stack".
516 If PORT is #f, use the standard error port.
517 If STACK is #f, never print the stack, regardless of whether printing it
518 is enabled. If STACK is #t, then print it if it is contained in ARGS
519 (i.e., KEY is gdb:with-stack). Otherwise STACK is the result of calling
520 scm_make_stack (which will be ignored in favor of the stack in ARGS if
521 KEY is gdb:with-stack).
522 KEY, ARGS are the standard arguments to scm_throw, et.al.
524 Basically this function is just a wrapper around calling
525 %print-exception-with-stack. */
528 gdbscm_print_exception_with_stack (SCM port
, SCM stack
, SCM key
, SCM args
)
532 if (gdbscm_is_false (port
))
533 port
= scm_current_error_port ();
535 if (gdbscm_is_false (percent_print_exception_with_stack_var
))
537 percent_print_exception_with_stack_var
538 = scm_c_private_variable (gdbscm_init_module_name
,
539 percent_print_exception_with_stack_name
);
540 /* If we can't find %print-exception-with-stack, there's a problem on the
541 Scheme side. Don't kill GDB, just flag an error and leave it at
543 if (gdbscm_is_false (percent_print_exception_with_stack_var
))
545 gdbscm_printf (port
, _("Error in Scheme exception printing,"
546 " can't find %s.\n"),
547 percent_print_exception_with_stack_name
);
551 printer
= scm_variable_ref (percent_print_exception_with_stack_var
);
553 status
= gdbscm_safe_call_4 (printer
, port
, stack
, key
, args
, NULL
);
555 /* If that failed still tell the user something.
556 But don't use the exception printing machinery! */
557 if (gdbscm_is_exception (status
))
559 gdbscm_printf (port
, _("Error in Scheme exception printing:\n"));
560 scm_display (status
, port
);
565 /* Print EXCEPTION, a <gdb:exception> object, to PORT.
566 If PORT is #f, use the standard error port. */
569 gdbscm_print_gdb_exception (SCM port
, SCM exception
)
571 gdb_assert (gdbscm_is_exception (exception
));
573 gdbscm_print_exception_with_stack (port
, SCM_BOOL_T
,
574 gdbscm_exception_key (exception
),
575 gdbscm_exception_args (exception
));
578 /* Return a string description of <gdb:exception> EXCEPTION.
579 If EXCEPTION is a gdb:with-stack exception, unwrap it, a backtrace
580 is never returned as part of the result. */
582 gdb::unique_xmalloc_ptr
<char>
583 gdbscm_exception_message_to_string (SCM exception
)
585 SCM port
= scm_open_output_string ();
588 gdb_assert (gdbscm_is_exception (exception
));
590 key
= gdbscm_exception_key (exception
);
591 args
= gdbscm_exception_args (exception
);
593 if (scm_is_eq (key
, with_stack_error_symbol
)
594 /* Don't crash on a badly generated gdb:with-stack exception. */
595 && scm_is_pair (args
)
596 && scm_is_pair (scm_cdr (args
)))
598 key
= scm_car (args
);
599 args
= scm_cddr (args
);
602 gdbscm_print_exception_message (port
, SCM_BOOL_F
, key
, args
);
603 gdb::unique_xmalloc_ptr
<char> result
604 = gdbscm_scm_to_c_string (scm_get_output_string (port
));
605 scm_close_port (port
);
609 /* Return the value of the "guile print-stack" option as one of:
610 'none, 'message, 'full. */
613 gdbscm_percent_exception_print_style (void)
615 if (gdbscm_print_excp
== gdbscm_print_excp_none
)
617 if (gdbscm_print_excp
== gdbscm_print_excp_message
)
618 return message_symbol
;
619 if (gdbscm_print_excp
== gdbscm_print_excp_full
)
621 gdb_assert_not_reached ("bad value for \"guile print-stack\"");
624 /* Return the current <gdb:exception> counter.
625 This is for debugging purposes. */
628 gdbscm_percent_exception_count (void)
630 return scm_from_ulong (gdbscm_exception_count
);
633 /* Initialize the Scheme exception support. */
635 static const scheme_function exception_functions
[] =
637 { "make-exception", 2, 0, 0, as_a_scm_t_subr (gdbscm_make_exception
),
639 Create a <gdb:exception> object.\n\
641 Arguments: key args\n\
642 These are the standard key,args arguments of \"throw\"." },
644 { "exception?", 1, 0, 0, as_a_scm_t_subr (gdbscm_exception_p
),
646 Return #t if the object is a <gdb:exception> object." },
648 { "exception-key", 1, 0, 0, as_a_scm_t_subr (gdbscm_exception_key
),
650 Return the exception's key." },
652 { "exception-args", 1, 0, 0, as_a_scm_t_subr (gdbscm_exception_args
),
654 Return the exception's arg list." },
659 static const scheme_function private_exception_functions
[] =
661 { "%exception-print-style", 0, 0, 0,
662 as_a_scm_t_subr (gdbscm_percent_exception_print_style
),
664 Return the value of the \"guile print-stack\" option." },
666 { "%exception-count", 0, 0, 0,
667 as_a_scm_t_subr (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");