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
);
115 /* The smob "print" function for <gdb:exception>. */
118 exscm_print_exception_smob (SCM self
, SCM port
, scm_print_state
*pstate
)
120 exception_smob
*e_smob
= (exception_smob
*) SCM_SMOB_DATA (self
);
122 gdbscm_printf (port
, "#<%s ", exception_smob_name
);
123 scm_write (e_smob
->key
, port
);
124 scm_puts (" ", port
);
125 scm_write (e_smob
->args
, port
);
126 scm_puts (">", port
);
128 scm_remember_upto_here_1 (self
);
130 /* Non-zero means success. */
134 /* (make-exception key args) -> <gdb:exception> */
137 gdbscm_make_exception (SCM key
, SCM args
)
139 exception_smob
*e_smob
= (exception_smob
*)
140 scm_gc_malloc (sizeof (exception_smob
), exception_smob_name
);
145 smob
= scm_new_smob (exception_smob_tag
, (scm_t_bits
) e_smob
);
146 gdbscm_init_gsmob (&e_smob
->base
);
148 ++gdbscm_exception_count
;
153 /* Return non-zero if SCM is a <gdb:exception> object. */
156 gdbscm_is_exception (SCM scm
)
158 return SCM_SMOB_PREDICATE (exception_smob_tag
, scm
);
161 /* (exception? scm) -> boolean */
164 gdbscm_exception_p (SCM scm
)
166 return scm_from_bool (gdbscm_is_exception (scm
));
169 /* (exception-key <gdb:exception>) -> key */
172 gdbscm_exception_key (SCM self
)
174 exception_smob
*e_smob
;
176 SCM_ASSERT_TYPE (gdbscm_is_exception (self
), self
, SCM_ARG1
, FUNC_NAME
,
179 e_smob
= (exception_smob
*) SCM_SMOB_DATA (self
);
183 /* (exception-args <gdb:exception>) -> arg-list */
186 gdbscm_exception_args (SCM self
)
188 exception_smob
*e_smob
;
190 SCM_ASSERT_TYPE (gdbscm_is_exception (self
), self
, SCM_ARG1
, FUNC_NAME
,
193 e_smob
= (exception_smob
*) SCM_SMOB_DATA (self
);
197 /* Wrap an exception in a <gdb:exception> object that includes STACK.
198 gdbscm_print_exception_with_stack knows how to unwrap it. */
201 gdbscm_make_exception_with_stack (SCM key
, SCM args
, SCM stack
)
203 return gdbscm_make_exception (with_stack_error_symbol
,
204 scm_cons (key
, scm_cons (stack
, args
)));
207 /* Version of scm_error_scm that creates a gdb:exception object that can later
208 be passed to gdbscm_throw.
209 KEY is a symbol denoting the kind of error.
210 SUBR is either #f or a string marking the function in which the error
212 MESSAGE is either #f or the error message string. It may contain ~a and ~s
213 modifiers, provided by ARGS.
214 ARGS is a list of args to MESSAGE.
215 DATA is an arbitrary object, its value depends on KEY. The value to pass
216 here is a bit underspecified by Guile. */
219 gdbscm_make_error_scm (SCM key
, SCM subr
, SCM message
, SCM args
, SCM data
)
221 return gdbscm_make_exception (key
, scm_list_4 (subr
, message
, args
, data
));
224 /* Version of scm_error that creates a gdb:exception object that can later
225 be passed to gdbscm_throw.
226 See gdbscm_make_error_scm for a description of the arguments. */
229 gdbscm_make_error (SCM key
, const char *subr
, const char *message
,
232 return gdbscm_make_error_scm
234 subr
== NULL
? SCM_BOOL_F
: scm_from_latin1_string (subr
),
235 message
== NULL
? SCM_BOOL_F
: scm_from_latin1_string (message
),
239 /* Version of SCM_ASSERT_TYPE/scm_wrong_type_arg_msg that creates a
240 gdb:exception object that can later be passed to gdbscm_throw. */
243 gdbscm_make_type_error (const char *subr
, int arg_pos
, SCM bad_value
,
244 const char *expected_type
)
251 if (expected_type
!= NULL
)
253 msg
= xstrprintf (_("Wrong type argument in position %d"
254 " (expecting %s): ~S"),
255 arg_pos
, expected_type
);
259 msg
= xstrprintf (_("Wrong type argument in position %d: ~S"),
265 if (expected_type
!= NULL
)
267 msg
= xstrprintf (_("Wrong type argument (expecting %s): ~S"),
271 msg
= xstrprintf (_("Wrong type argument: ~S"));
274 result
= gdbscm_make_error (scm_arg_type_key
, subr
, msg
,
275 scm_list_1 (bad_value
), scm_list_1 (bad_value
));
280 /* A variant of gdbscm_make_type_error for non-type argument errors.
281 ERROR_PREFIX and ERROR are combined to build the error message.
282 Care needs to be taken so that the i18n composed form is still
283 reasonable, but no one is going to translate these anyway so we don't
285 ERROR_PREFIX may be NULL, ERROR may not be NULL. */
288 gdbscm_make_arg_error (SCM key
, const char *subr
, int arg_pos
, SCM bad_value
,
289 const char *error_prefix
, const char *error
)
294 if (error_prefix
!= NULL
)
298 msg
= xstrprintf (_("%s %s in position %d: ~S"),
299 error_prefix
, error
, arg_pos
);
302 msg
= xstrprintf (_("%s %s: ~S"), error_prefix
, error
);
307 msg
= xstrprintf (_("%s in position %d: ~S"), error
, arg_pos
);
309 msg
= xstrprintf (_("%s: ~S"), error
);
312 result
= gdbscm_make_error (key
, subr
, msg
,
313 scm_list_1 (bad_value
), scm_list_1 (bad_value
));
318 /* Make an invalid-object error <gdb:exception> object.
319 OBJECT is the name of the kind of object that is invalid. */
322 gdbscm_make_invalid_object_error (const char *subr
, int arg_pos
, SCM bad_value
,
325 return gdbscm_make_arg_error (gdbscm_invalid_object_error_symbol
,
326 subr
, arg_pos
, bad_value
,
327 _("Invalid object:"), object
);
330 /* Throw an invalid-object error.
331 OBJECT is the name of the kind of object that is invalid. */
334 gdbscm_invalid_object_error (const char *subr
, int arg_pos
, SCM bad_value
,
338 = gdbscm_make_invalid_object_error (subr
, arg_pos
, bad_value
, object
);
340 gdbscm_throw (exception
);
343 /* Make an out-of-range error <gdb:exception> object. */
346 gdbscm_make_out_of_range_error (const char *subr
, int arg_pos
, SCM bad_value
,
349 return gdbscm_make_arg_error (scm_out_of_range_key
,
350 subr
, arg_pos
, bad_value
,
351 _("Out of range:"), error
);
354 /* Throw an out-of-range error.
355 This is the standard Guile out-of-range exception. */
358 gdbscm_out_of_range_error (const char *subr
, int arg_pos
, SCM bad_value
,
362 = gdbscm_make_out_of_range_error (subr
, arg_pos
, bad_value
, error
);
364 gdbscm_throw (exception
);
367 /* Make a misc-error <gdb:exception> object. */
370 gdbscm_make_misc_error (const char *subr
, int arg_pos
, SCM bad_value
,
373 return gdbscm_make_arg_error (scm_misc_error_key
,
374 subr
, arg_pos
, bad_value
, NULL
, error
);
377 /* Return a <gdb:exception> object for gdb:memory-error. */
380 gdbscm_make_memory_error (const char *subr
, const char *msg
, SCM args
)
382 return gdbscm_make_error (memory_error_symbol
, subr
, msg
, args
,
386 /* Throw a gdb:memory-error exception. */
389 gdbscm_memory_error (const char *subr
, const char *msg
, SCM args
)
391 SCM exception
= gdbscm_make_memory_error (subr
, msg
, args
);
393 gdbscm_throw (exception
);
396 /* Return non-zero if KEY is gdb:memory-error.
397 Note: This is an excp_matcher_func function. */
400 gdbscm_memory_error_p (SCM key
)
402 return scm_is_eq (key
, memory_error_symbol
);
405 /* Wrapper around scm_throw to throw a gdb:exception.
406 This function does not return.
407 This function cannot be called from inside TRY_CATCH. */
410 gdbscm_throw (SCM exception
)
412 scm_throw (gdbscm_exception_key (exception
),
413 gdbscm_exception_args (exception
));
414 gdb_assert_not_reached ("scm_throw returned");
417 /* Convert a GDB exception to a <gdb:exception> object. */
420 gdbscm_scm_from_gdb_exception (struct gdb_exception exception
)
424 if (exception
.reason
== RETURN_QUIT
)
426 /* Handle this specially to be consistent with top-repl.scm. */
427 return gdbscm_make_error (signal_symbol
, NULL
, _("User interrupt"),
428 SCM_EOL
, scm_list_1 (scm_from_int (SIGINT
)));
431 if (exception
.error
== MEMORY_ERROR
)
432 key
= memory_error_symbol
;
436 return gdbscm_make_error (key
, NULL
, "~A",
437 scm_list_1 (gdbscm_scm_from_c_string
438 (exception
.message
)),
442 /* Convert a GDB exception to the appropriate Scheme exception and throw it.
443 This function does not return. */
446 gdbscm_throw_gdb_exception (struct gdb_exception exception
)
448 gdbscm_throw (gdbscm_scm_from_gdb_exception (exception
));
451 /* Print the error message portion of an exception.
452 If PORT is #f, use the standard error port.
453 KEY cannot be gdb:with-stack.
455 Basically this function is just a wrapper around calling
456 %print-exception-message. */
459 gdbscm_print_exception_message (SCM port
, SCM frame
, SCM key
, SCM args
)
463 if (gdbscm_is_false (port
))
464 port
= scm_current_error_port ();
466 gdb_assert (!scm_is_eq (key
, with_stack_error_symbol
));
468 /* This does not use scm_print_exception because we tweak the output a bit.
469 Compare Guile's print-exception with our %print-exception-message for
471 if (gdbscm_is_false (percent_print_exception_message_var
))
473 percent_print_exception_message_var
474 = scm_c_private_variable (gdbscm_init_module_name
,
475 percent_print_exception_message_name
);
476 /* If we can't find %print-exception-message, there's a problem on the
477 Scheme side. Don't kill GDB, just flag an error and leave it at
479 if (gdbscm_is_false (percent_print_exception_message_var
))
481 gdbscm_printf (port
, _("Error in Scheme exception printing,"
482 " can't find %s.\n"),
483 percent_print_exception_message_name
);
487 printer
= scm_variable_ref (percent_print_exception_message_var
);
489 status
= gdbscm_safe_call_4 (printer
, port
, frame
, key
, args
, NULL
);
491 /* If that failed still tell the user something.
492 But don't use the exception printing machinery! */
493 if (gdbscm_is_exception (status
))
495 gdbscm_printf (port
, _("Error in Scheme exception printing:\n"));
496 scm_display (status
, port
);
501 /* Print the description of exception KEY, ARGS to PORT, according to the
502 setting of "set guile print-stack".
503 If PORT is #f, use the standard error port.
504 If STACK is #f, never print the stack, regardless of whether printing it
505 is enabled. If STACK is #t, then print it if it is contained in ARGS
506 (i.e., KEY is gdb:with-stack). Otherwise STACK is the result of calling
507 scm_make_stack (which will be ignored in favor of the stack in ARGS if
508 KEY is gdb:with-stack).
509 KEY, ARGS are the standard arguments to scm_throw, et.al.
511 Basically this function is just a wrapper around calling
512 %print-exception-with-args. */
515 gdbscm_print_exception_with_stack (SCM port
, SCM stack
, SCM key
, SCM args
)
519 if (gdbscm_is_false (port
))
520 port
= scm_current_error_port ();
522 if (gdbscm_is_false (percent_print_exception_with_stack_var
))
524 percent_print_exception_with_stack_var
525 = scm_c_private_variable (gdbscm_init_module_name
,
526 percent_print_exception_with_stack_name
);
527 /* If we can't find %print-exception-with-args, there's a problem on the
528 Scheme side. Don't kill GDB, just flag an error and leave it at
530 if (gdbscm_is_false (percent_print_exception_with_stack_var
))
532 gdbscm_printf (port
, _("Error in Scheme exception printing,"
533 " can't find %s.\n"),
534 percent_print_exception_with_stack_name
);
538 printer
= scm_variable_ref (percent_print_exception_with_stack_var
);
540 status
= gdbscm_safe_call_4 (printer
, port
, stack
, key
, args
, NULL
);
542 /* If that failed still tell the user something.
543 But don't use the exception printing machinery! */
544 if (gdbscm_is_exception (status
))
546 gdbscm_printf (port
, _("Error in Scheme exception printing:\n"));
547 scm_display (status
, port
);
552 /* Print EXCEPTION, a <gdb:exception> object, to PORT.
553 If PORT is #f, use the standard error port. */
556 gdbscm_print_gdb_exception (SCM port
, SCM exception
)
558 gdb_assert (gdbscm_is_exception (exception
));
560 gdbscm_print_exception_with_stack (port
, SCM_BOOL_T
,
561 gdbscm_exception_key (exception
),
562 gdbscm_exception_args (exception
));
565 /* Return a string description of <gdb:exception> EXCEPTION.
566 If EXCEPTION is a gdb:with-stack exception, unwrap it, a backtrace
567 is never returned as part of the result.
569 Space for the result is malloc'd, the caller must free. */
572 gdbscm_exception_message_to_string (SCM exception
)
574 SCM port
= scm_open_output_string ();
578 gdb_assert (gdbscm_is_exception (exception
));
580 key
= gdbscm_exception_key (exception
);
581 args
= gdbscm_exception_args (exception
);
583 if (scm_is_eq (key
, with_stack_error_symbol
)
584 /* Don't crash on a badly generated gdb:with-stack exception. */
585 && scm_is_pair (args
)
586 && scm_is_pair (scm_cdr (args
)))
588 key
= scm_car (args
);
589 args
= scm_cddr (args
);
592 gdbscm_print_exception_message (port
, SCM_BOOL_F
, key
, args
);
593 result
= gdbscm_scm_to_c_string (scm_get_output_string (port
));
594 scm_close_port (port
);
599 /* Return the value of the "guile print-stack" option as one of:
600 'none, 'message, 'full. */
603 gdbscm_percent_exception_print_style (void)
605 if (gdbscm_print_excp
== gdbscm_print_excp_none
)
607 if (gdbscm_print_excp
== gdbscm_print_excp_message
)
608 return message_symbol
;
609 if (gdbscm_print_excp
== gdbscm_print_excp_full
)
611 gdb_assert_not_reached ("bad value for \"guile print-stack\"");
614 /* Return the current <gdb:exception> counter.
615 This is for debugging purposes. */
618 gdbscm_percent_exception_count (void)
620 return scm_from_ulong (gdbscm_exception_count
);
623 /* Initialize the Scheme exception support. */
625 static const scheme_function exception_functions
[] =
627 { "make-exception", 2, 0, 0, gdbscm_make_exception
,
629 Create a <gdb:exception> object.\n\
631 Arguments: key args\n\
632 These are the standard key,args arguments of \"throw\"." },
634 { "exception?", 1, 0, 0, gdbscm_exception_p
,
636 Return #t if the object is a <gdb:exception> object." },
638 { "exception-key", 1, 0, 0, gdbscm_exception_key
,
640 Return the exception's key." },
642 { "exception-args", 1, 0, 0, gdbscm_exception_args
,
644 Return the exception's arg list." },
649 static const scheme_function private_exception_functions
[] =
651 { "%exception-print-style", 0, 0, 0, gdbscm_percent_exception_print_style
,
653 Return the value of the \"guile print-stack\" option." },
655 { "%exception-count", 0, 0, 0, gdbscm_percent_exception_count
,
657 Return a count of the number of <gdb:exception> objects created.\n\
658 This is for debugging purposes." },
664 gdbscm_initialize_exceptions (void)
666 exception_smob_tag
= gdbscm_make_smob_type (exception_smob_name
,
667 sizeof (exception_smob
));
668 scm_set_smob_mark (exception_smob_tag
, exscm_mark_exception_smob
);
669 scm_set_smob_print (exception_smob_tag
, exscm_print_exception_smob
);
671 gdbscm_define_functions (exception_functions
, 1);
672 gdbscm_define_functions (private_exception_functions
, 0);
674 error_symbol
= scm_from_latin1_symbol ("gdb:error");
676 memory_error_symbol
= scm_from_latin1_symbol ("gdb:memory-error");
678 gdbscm_invalid_object_error_symbol
679 = scm_from_latin1_symbol ("gdb:invalid-object-error");
681 with_stack_error_symbol
= scm_from_latin1_symbol ("gdb:with-stack");
683 /* The text of this symbol is taken from Guile's top-repl.scm. */
684 signal_symbol
= scm_from_latin1_symbol ("signal");
686 none_symbol
= scm_from_latin1_symbol ("none");
687 message_symbol
= scm_from_latin1_symbol ("message");
688 full_symbol
= scm_from_latin1_symbol ("full");