1 /* GDB/Scheme exception support. 2 3 Copyright (C) 2014-2023 Free Software Foundation, Inc. 4 5 This file is part of GDB. 6 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. 11 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. 16 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/>. */ 19 20 /* See README file in this directory for implementation notes, coding 21 conventions, et.al. */ 22 23 /* Notes: 24 25 IWBN to support SRFI 34/35. At the moment we follow Guile's own 26 exception mechanism. 27 28 The non-static functions in this file have prefix gdbscm_ and 29 not exscm_ on purpose. */ 30 31 #include "defs.h" 32 #include <signal.h> 33 #include "guile-internal.h" 34 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. */ 39 40 struct exception_smob 41 { 42 /* This always appears first. */ 43 gdb_smob base; 44 45 /* The key and args parameters to "throw". */ 46 SCM key; 47 SCM args; 48 }; 49 50 static const char exception_smob_name[] = "gdb:exception"; 51 52 /* The tag Guile knows the exception smob by. */ 53 static scm_t_bits exception_smob_tag; 54 55 /* A generic error in struct gdb_exception. 56 I.e., not RETURN_QUIT and not MEMORY_ERROR. */ 57 static SCM error_symbol; 58 59 /* An error occurred accessing inferior memory. 60 This is not a Scheme programming error. */ 61 static SCM memory_error_symbol; 62 63 /* User interrupt, e.g., RETURN_QUIT in struct gdb_exception. */ 64 static SCM signal_symbol; 65 66 /* A user error, e.g., bad arg to gdb command. */ 67 static SCM user_error_symbol; 68 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; 74 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; 78 79 /* Values for "guile print-stack" as symbols. */ 80 static SCM none_symbol; 81 static SCM message_symbol; 82 static SCM full_symbol; 83 84 static const char percent_print_exception_message_name[] = 85 "%print-exception-message"; 86 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; 91 92 static const char percent_print_exception_with_stack_name[] = 93 "%print-exception-with-stack"; 94 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; 99 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; 103 104 /* Administrivia for exception smobs. */ 105 106 /* The smob "print" function for <gdb:exception>. */ 107 108 static int 109 exscm_print_exception_smob (SCM self, SCM port, scm_print_state *pstate) 110 { 111 exception_smob *e_smob = (exception_smob *) SCM_SMOB_DATA (self); 112 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); 118 119 scm_remember_upto_here_1 (self); 120 121 /* Non-zero means success. */ 122 return 1; 123 } 124 125 /* (make-exception key args) -> <gdb:exception> */ 126 127 SCM 128 gdbscm_make_exception (SCM key, SCM args) 129 { 130 exception_smob *e_smob = (exception_smob *) 131 scm_gc_malloc (sizeof (exception_smob), exception_smob_name); 132 SCM smob; 133 134 e_smob->key = key; 135 e_smob->args = args; 136 smob = scm_new_smob (exception_smob_tag, (scm_t_bits) e_smob); 137 gdbscm_init_gsmob (&e_smob->base); 138 139 ++gdbscm_exception_count; 140 141 return smob; 142 } 143 144 /* Return non-zero if SCM is a <gdb:exception> object. */ 145 146 int 147 gdbscm_is_exception (SCM scm) 148 { 149 return SCM_SMOB_PREDICATE (exception_smob_tag, scm); 150 } 151 152 /* (exception? scm) -> boolean */ 153 154 static SCM 155 gdbscm_exception_p (SCM scm) 156 { 157 return scm_from_bool (gdbscm_is_exception (scm)); 158 } 159 160 /* (exception-key <gdb:exception>) -> key */ 161 162 SCM 163 gdbscm_exception_key (SCM self) 164 { 165 exception_smob *e_smob; 166 167 SCM_ASSERT_TYPE (gdbscm_is_exception (self), self, SCM_ARG1, FUNC_NAME, 168 "gdb:exception"); 169 170 e_smob = (exception_smob *) SCM_SMOB_DATA (self); 171 return e_smob->key; 172 } 173 174 /* (exception-args <gdb:exception>) -> arg-list */ 175 176 SCM 177 gdbscm_exception_args (SCM self) 178 { 179 exception_smob *e_smob; 180 181 SCM_ASSERT_TYPE (gdbscm_is_exception (self), self, SCM_ARG1, FUNC_NAME, 182 "gdb:exception"); 183 184 e_smob = (exception_smob *) SCM_SMOB_DATA (self); 185 return e_smob->args; 186 } 187 188 /* Wrap an exception in a <gdb:exception> object that includes STACK. 189 gdbscm_print_exception_with_stack knows how to unwrap it. */ 190 191 SCM 192 gdbscm_make_exception_with_stack (SCM key, SCM args, SCM stack) 193 { 194 return gdbscm_make_exception (with_stack_error_symbol, 195 scm_cons (key, scm_cons (stack, args))); 196 } 197 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 202 occurred. 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. */ 208 209 SCM 210 gdbscm_make_error_scm (SCM key, SCM subr, SCM message, SCM args, SCM data) 211 { 212 return gdbscm_make_exception (key, scm_list_4 (subr, message, args, data)); 213 } 214 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. */ 218 219 SCM 220 gdbscm_make_error (SCM key, const char *subr, const char *message, 221 SCM args, SCM data) 222 { 223 return gdbscm_make_error_scm 224 (key, 225 subr == NULL ? SCM_BOOL_F : scm_from_latin1_string (subr), 226 message == NULL ? SCM_BOOL_F : scm_from_latin1_string (message), 227 args, data); 228 } 229 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. */ 232 233 SCM 234 gdbscm_make_type_error (const char *subr, int arg_pos, SCM bad_value, 235 const char *expected_type) 236 { 237 gdb::unique_xmalloc_ptr<char> msg; 238 SCM result; 239 240 if (arg_pos > 0) 241 { 242 if (expected_type != NULL) 243 { 244 msg = xstrprintf (_("Wrong type argument in position %d" 245 " (expecting %s): ~S"), 246 arg_pos, expected_type); 247 } 248 else 249 { 250 msg = xstrprintf (_("Wrong type argument in position %d: ~S"), 251 arg_pos); 252 } 253 } 254 else 255 { 256 if (expected_type != NULL) 257 { 258 msg = xstrprintf (_("Wrong type argument (expecting %s): ~S"), 259 expected_type); 260 } 261 else 262 msg = xstrprintf (_("Wrong type argument: ~S")); 263 } 264 265 result = gdbscm_make_error (scm_arg_type_key, subr, msg.get (), 266 scm_list_1 (bad_value), scm_list_1 (bad_value)); 267 return result; 268 } 269 270 /* A variant of gdbscm_make_type_error for non-type argument errors. 271 ERROR_PREFIX and ERROR are combined to build the error message. 272 Care needs to be taken so that the i18n composed form is still 273 reasonable, but no one is going to translate these anyway so we don't 274 worry too much. 275 ERROR_PREFIX may be NULL, ERROR may not be NULL. */ 276 277 static SCM 278 gdbscm_make_arg_error (SCM key, const char *subr, int arg_pos, SCM bad_value, 279 const char *error_prefix, const char *error) 280 { 281 gdb::unique_xmalloc_ptr<char> msg; 282 SCM result; 283 284 if (error_prefix != NULL) 285 { 286 if (arg_pos > 0) 287 { 288 msg = xstrprintf (_("%s %s in position %d: ~S"), 289 error_prefix, error, arg_pos); 290 } 291 else 292 msg = xstrprintf (_("%s %s: ~S"), error_prefix, error); 293 } 294 else 295 { 296 if (arg_pos > 0) 297 msg = xstrprintf (_("%s in position %d: ~S"), error, arg_pos); 298 else 299 msg = xstrprintf (_("%s: ~S"), error); 300 } 301 302 result = gdbscm_make_error (key, subr, msg.get (), scm_list_1 (bad_value), 303 scm_list_1 (bad_value)); 304 return result; 305 } 306 307 /* Make an invalid-object error <gdb:exception> object. 308 OBJECT is the name of the kind of object that is invalid. */ 309 310 SCM 311 gdbscm_make_invalid_object_error (const char *subr, int arg_pos, SCM bad_value, 312 const char *object) 313 { 314 return gdbscm_make_arg_error (gdbscm_invalid_object_error_symbol, 315 subr, arg_pos, bad_value, 316 _("Invalid object:"), object); 317 } 318 319 /* Throw an invalid-object error. 320 OBJECT is the name of the kind of object that is invalid. */ 321 322 void 323 gdbscm_invalid_object_error (const char *subr, int arg_pos, SCM bad_value, 324 const char *object) 325 { 326 SCM exception 327 = gdbscm_make_invalid_object_error (subr, arg_pos, bad_value, object); 328 329 gdbscm_throw (exception); 330 } 331 332 /* Make an out-of-range error <gdb:exception> object. */ 333 334 SCM 335 gdbscm_make_out_of_range_error (const char *subr, int arg_pos, SCM bad_value, 336 const char *error) 337 { 338 return gdbscm_make_arg_error (scm_out_of_range_key, 339 subr, arg_pos, bad_value, 340 _("Out of range:"), error); 341 } 342 343 /* Throw an out-of-range error. 344 This is the standard Guile out-of-range exception. */ 345 346 void 347 gdbscm_out_of_range_error (const char *subr, int arg_pos, SCM bad_value, 348 const char *error) 349 { 350 SCM exception 351 = gdbscm_make_out_of_range_error (subr, arg_pos, bad_value, error); 352 353 gdbscm_throw (exception); 354 } 355 356 /* Make a misc-error <gdb:exception> object. */ 357 358 SCM 359 gdbscm_make_misc_error (const char *subr, int arg_pos, SCM bad_value, 360 const char *error) 361 { 362 return gdbscm_make_arg_error (scm_misc_error_key, 363 subr, arg_pos, bad_value, NULL, error); 364 } 365 366 /* Throw a misc-error error. */ 367 368 void 369 gdbscm_misc_error (const char *subr, int arg_pos, SCM bad_value, 370 const char *error) 371 { 372 SCM exception = gdbscm_make_misc_error (subr, arg_pos, bad_value, error); 373 374 gdbscm_throw (exception); 375 } 376 377 /* Return a <gdb:exception> object for gdb:memory-error. */ 378 379 SCM 380 gdbscm_make_memory_error (const char *subr, const char *msg, SCM args) 381 { 382 return gdbscm_make_error (memory_error_symbol, subr, msg, args, 383 SCM_EOL); 384 } 385 386 /* Throw a gdb:memory-error exception. */ 387 388 void 389 gdbscm_memory_error (const char *subr, const char *msg, SCM args) 390 { 391 SCM exception = gdbscm_make_memory_error (subr, msg, args); 392 393 gdbscm_throw (exception); 394 } 395 396 /* Return non-zero if KEY is gdb:memory-error. 397 Note: This is an excp_matcher_func function. */ 398 399 int 400 gdbscm_memory_error_p (SCM key) 401 { 402 return scm_is_eq (key, memory_error_symbol); 403 } 404 405 /* Return non-zero if KEY is gdb:user-error. 406 Note: This is an excp_matcher_func function. */ 407 408 int 409 gdbscm_user_error_p (SCM key) 410 { 411 return scm_is_eq (key, user_error_symbol); 412 } 413 414 /* Wrapper around scm_throw to throw a gdb:exception. 415 This function does not return. 416 This function cannot be called from inside TRY_CATCH. */ 417 418 void 419 gdbscm_throw (SCM exception) 420 { 421 scm_throw (gdbscm_exception_key (exception), 422 gdbscm_exception_args (exception)); 423 gdb_assert_not_reached ("scm_throw returned"); 424 } 425 426 /* Convert a GDB exception to a <gdb:exception> object. */ 427 428 SCM 429 gdbscm_scm_from_gdb_exception (const gdbscm_gdb_exception &exception) 430 { 431 SCM key; 432 433 if (exception.reason == RETURN_QUIT) 434 { 435 /* Handle this specially to be consistent with top-repl.scm. */ 436 return gdbscm_make_error (signal_symbol, NULL, _("User interrupt"), 437 SCM_EOL, scm_list_1 (scm_from_int (SIGINT))); 438 } 439 440 if (exception.error == MEMORY_ERROR) 441 key = memory_error_symbol; 442 else 443 key = error_symbol; 444 445 return gdbscm_make_error (key, NULL, "~A", 446 scm_list_1 (gdbscm_scm_from_c_string 447 (exception.message)), 448 SCM_BOOL_F); 449 } 450 451 /* Convert a GDB exception to the appropriate Scheme exception and throw it. 452 This function does not return. */ 453 454 void 455 gdbscm_throw_gdb_exception (gdbscm_gdb_exception exception) 456 { 457 SCM scm_exception = gdbscm_scm_from_gdb_exception (exception); 458 xfree (exception.message); 459 gdbscm_throw (scm_exception); 460 } 461 462 /* Print the error message portion of an exception. 463 If PORT is #f, use the standard error port. 464 KEY cannot be gdb:with-stack. 465 466 Basically this function is just a wrapper around calling 467 %print-exception-message. */ 468 469 static void 470 gdbscm_print_exception_message (SCM port, SCM frame, SCM key, SCM args) 471 { 472 SCM printer, status; 473 474 if (gdbscm_is_false (port)) 475 port = scm_current_error_port (); 476 477 gdb_assert (!scm_is_eq (key, with_stack_error_symbol)); 478 479 /* This does not use scm_print_exception because we tweak the output a bit. 480 Compare Guile's print-exception with our %print-exception-message for 481 details. */ 482 if (gdbscm_is_false (percent_print_exception_message_var)) 483 { 484 percent_print_exception_message_var 485 = scm_c_private_variable (gdbscm_init_module_name, 486 percent_print_exception_message_name); 487 /* If we can't find %print-exception-message, there's a problem on the 488 Scheme side. Don't kill GDB, just flag an error and leave it at 489 that. */ 490 if (gdbscm_is_false (percent_print_exception_message_var)) 491 { 492 gdbscm_printf (port, _("Error in Scheme exception printing," 493 " can't find %s.\n"), 494 percent_print_exception_message_name); 495 return; 496 } 497 } 498 printer = scm_variable_ref (percent_print_exception_message_var); 499 500 status = gdbscm_safe_call_4 (printer, port, frame, key, args, NULL); 501 502 /* If that failed still tell the user something. 503 But don't use the exception printing machinery! */ 504 if (gdbscm_is_exception (status)) 505 { 506 gdbscm_printf (port, _("Error in Scheme exception printing:\n")); 507 scm_display (status, port); 508 scm_newline (port); 509 } 510 } 511 512 /* Print the description of exception KEY, ARGS to PORT, according to the 513 setting of "set guile print-stack". 514 If PORT is #f, use the standard error port. 515 If STACK is #f, never print the stack, regardless of whether printing it 516 is enabled. If STACK is #t, then print it if it is contained in ARGS 517 (i.e., KEY is gdb:with-stack). Otherwise STACK is the result of calling 518 scm_make_stack (which will be ignored in favor of the stack in ARGS if 519 KEY is gdb:with-stack). 520 KEY, ARGS are the standard arguments to scm_throw, et.al. 521 522 Basically this function is just a wrapper around calling 523 %print-exception-with-stack. */ 524 525 void 526 gdbscm_print_exception_with_stack (SCM port, SCM stack, SCM key, SCM args) 527 { 528 SCM printer, status; 529 530 if (gdbscm_is_false (port)) 531 port = scm_current_error_port (); 532 533 if (gdbscm_is_false (percent_print_exception_with_stack_var)) 534 { 535 percent_print_exception_with_stack_var 536 = scm_c_private_variable (gdbscm_init_module_name, 537 percent_print_exception_with_stack_name); 538 /* If we can't find %print-exception-with-stack, there's a problem on the 539 Scheme side. Don't kill GDB, just flag an error and leave it at 540 that. */ 541 if (gdbscm_is_false (percent_print_exception_with_stack_var)) 542 { 543 gdbscm_printf (port, _("Error in Scheme exception printing," 544 " can't find %s.\n"), 545 percent_print_exception_with_stack_name); 546 return; 547 } 548 } 549 printer = scm_variable_ref (percent_print_exception_with_stack_var); 550 551 status = gdbscm_safe_call_4 (printer, port, stack, key, args, NULL); 552 553 /* If that failed still tell the user something. 554 But don't use the exception printing machinery! */ 555 if (gdbscm_is_exception (status)) 556 { 557 gdbscm_printf (port, _("Error in Scheme exception printing:\n")); 558 scm_display (status, port); 559 scm_newline (port); 560 } 561 } 562 563 /* Print EXCEPTION, a <gdb:exception> object, to PORT. 564 If PORT is #f, use the standard error port. */ 565 566 void 567 gdbscm_print_gdb_exception (SCM port, SCM exception) 568 { 569 gdb_assert (gdbscm_is_exception (exception)); 570 571 gdbscm_print_exception_with_stack (port, SCM_BOOL_T, 572 gdbscm_exception_key (exception), 573 gdbscm_exception_args (exception)); 574 } 575 576 /* Return a string description of <gdb:exception> EXCEPTION. 577 If EXCEPTION is a gdb:with-stack exception, unwrap it, a backtrace 578 is never returned as part of the result. */ 579 580 gdb::unique_xmalloc_ptr<char> 581 gdbscm_exception_message_to_string (SCM exception) 582 { 583 SCM port = scm_open_output_string (); 584 SCM key, args; 585 586 gdb_assert (gdbscm_is_exception (exception)); 587 588 key = gdbscm_exception_key (exception); 589 args = gdbscm_exception_args (exception); 590 591 if (scm_is_eq (key, with_stack_error_symbol) 592 /* Don't crash on a badly generated gdb:with-stack exception. */ 593 && scm_is_pair (args) 594 && scm_is_pair (scm_cdr (args))) 595 { 596 key = scm_car (args); 597 args = scm_cddr (args); 598 } 599 600 gdbscm_print_exception_message (port, SCM_BOOL_F, key, args); 601 gdb::unique_xmalloc_ptr<char> result 602 = gdbscm_scm_to_c_string (scm_get_output_string (port)); 603 scm_close_port (port); 604 return result; 605 } 606 607 /* Return the value of the "guile print-stack" option as one of: 608 'none, 'message, 'full. */ 609 610 static SCM 611 gdbscm_percent_exception_print_style (void) 612 { 613 if (gdbscm_print_excp == gdbscm_print_excp_none) 614 return none_symbol; 615 if (gdbscm_print_excp == gdbscm_print_excp_message) 616 return message_symbol; 617 if (gdbscm_print_excp == gdbscm_print_excp_full) 618 return full_symbol; 619 gdb_assert_not_reached ("bad value for \"guile print-stack\""); 620 } 621 622 /* Return the current <gdb:exception> counter. 623 This is for debugging purposes. */ 624 625 static SCM 626 gdbscm_percent_exception_count (void) 627 { 628 return scm_from_ulong (gdbscm_exception_count); 629 } 630 631 /* Initialize the Scheme exception support. */ 632 633 static const scheme_function exception_functions[] = 634 { 635 { "make-exception", 2, 0, 0, as_a_scm_t_subr (gdbscm_make_exception), 636 "\ 637 Create a <gdb:exception> object.\n\ 638 \n\ 639 Arguments: key args\n\ 640 These are the standard key,args arguments of \"throw\"." }, 641 642 { "exception?", 1, 0, 0, as_a_scm_t_subr (gdbscm_exception_p), 643 "\ 644 Return #t if the object is a <gdb:exception> object." }, 645 646 { "exception-key", 1, 0, 0, as_a_scm_t_subr (gdbscm_exception_key), 647 "\ 648 Return the exception's key." }, 649 650 { "exception-args", 1, 0, 0, as_a_scm_t_subr (gdbscm_exception_args), 651 "\ 652 Return the exception's arg list." }, 653 654 END_FUNCTIONS 655 }; 656 657 static const scheme_function private_exception_functions[] = 658 { 659 { "%exception-print-style", 0, 0, 0, 660 as_a_scm_t_subr (gdbscm_percent_exception_print_style), 661 "\ 662 Return the value of the \"guile print-stack\" option." }, 663 664 { "%exception-count", 0, 0, 0, 665 as_a_scm_t_subr (gdbscm_percent_exception_count), 666 "\ 667 Return a count of the number of <gdb:exception> objects created.\n\ 668 This is for debugging purposes." }, 669 670 END_FUNCTIONS 671 }; 672 673 void 674 gdbscm_initialize_exceptions (void) 675 { 676 exception_smob_tag = gdbscm_make_smob_type (exception_smob_name, 677 sizeof (exception_smob)); 678 scm_set_smob_print (exception_smob_tag, exscm_print_exception_smob); 679 680 gdbscm_define_functions (exception_functions, 1); 681 gdbscm_define_functions (private_exception_functions, 0); 682 683 error_symbol = scm_from_latin1_symbol ("gdb:error"); 684 685 memory_error_symbol = scm_from_latin1_symbol ("gdb:memory-error"); 686 687 user_error_symbol = scm_from_latin1_symbol ("gdb:user-error"); 688 689 gdbscm_invalid_object_error_symbol 690 = scm_from_latin1_symbol ("gdb:invalid-object-error"); 691 692 with_stack_error_symbol = scm_from_latin1_symbol ("gdb:with-stack"); 693 694 /* The text of this symbol is taken from Guile's top-repl.scm. */ 695 signal_symbol = scm_from_latin1_symbol ("signal"); 696 697 none_symbol = scm_from_latin1_symbol ("none"); 698 message_symbol = scm_from_latin1_symbol ("message"); 699 full_symbol = scm_from_latin1_symbol ("full"); 700 } 701