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