gdb/guile/scm-exception.c

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