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