1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
28 #include "libguile/_scm.h"
29 #include "libguile/smob.h"
30 #include "libguile/eval.h"
31 #include "libguile/eq.h"
32 #include "libguile/control.h"
33 #include "libguile/deprecation.h"
34 #include "libguile/backtrace.h"
35 #include "libguile/debug.h"
36 #include "libguile/stackchk.h"
37 #include "libguile/stacks.h"
38 #include "libguile/fluids.h"
39 #include "libguile/ports.h"
40 #include "libguile/validate.h"
41 #include "libguile/vm.h"
42 #include "libguile/throw.h"
43 #include "libguile/init.h"
44 #include "libguile/strings.h"
46 #include "libguile/private-options.h"
49 /* Pleasantly enough, the guts of catch are defined in Scheme, in terms
50 of prompt, abort, and the %exception-handler fluid. Check boot-9 for
53 Still, it's useful to be able to throw unwind-only exceptions from C,
54 for example so that we can recover from stack overflow. We also need
55 to have an implementation of catch and throw handy before boot time.
56 For that reason we have a parallel implementation of "catch" that
57 uses the same fluids here. Throws from C still call out to Scheme
58 though, so that pre-unwind handlers can be run. Getting the dynamic
59 environment right for pre-unwind handlers is tricky, and it's
60 important to have all of the implementation in one place.
62 All of these function names and prototypes carry a fair bit of historical
70 static SCM exception_handler_fluid
;
73 catch (SCM tag
, SCM thunk
, SCM handler
, SCM pre_unwind_handler
)
78 scm_t_dynstack
*dynstack
= &SCM_I_CURRENT_THREAD
->dynstack
;
79 SCM dynamic_state
= SCM_I_CURRENT_THREAD
->dynamic_state
;
80 scm_i_jmp_buf registers
;
81 scm_t_ptrdiff saved_stack_depth
;
83 if (!scm_is_eq (tag
, SCM_BOOL_T
) && !scm_is_symbol (tag
))
84 scm_wrong_type_arg ("catch", 1, tag
);
86 if (SCM_UNBNDP (handler
))
88 else if (!scm_is_true (scm_procedure_p (handler
)))
89 scm_wrong_type_arg ("catch", 3, handler
);
91 if (SCM_UNBNDP (pre_unwind_handler
))
92 pre_unwind_handler
= SCM_BOOL_F
;
93 else if (!scm_is_true (scm_procedure_p (pre_unwind_handler
)))
94 scm_wrong_type_arg ("catch", 4, pre_unwind_handler
);
96 prompt_tag
= scm_cons (SCM_INUM0
, SCM_EOL
);
98 eh
= scm_c_make_vector (4, SCM_BOOL_F
);
99 scm_c_vector_set_x (eh
, 0, scm_fluid_ref (exception_handler_fluid
));
100 scm_c_vector_set_x (eh
, 1, tag
);
101 scm_c_vector_set_x (eh
, 2, prompt_tag
);
102 scm_c_vector_set_x (eh
, 3, pre_unwind_handler
);
105 saved_stack_depth
= vp
->sp
- vp
->stack_base
;
107 /* Push the prompt and exception handler onto the dynamic stack. */
108 scm_dynstack_push_prompt (dynstack
,
109 SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
110 | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS
,
112 vp
->fp
- vp
->stack_base
,
116 scm_dynstack_push_fluid (dynstack
, exception_handler_fluid
, eh
,
119 if (SCM_I_SETJMP (registers
))
121 /* A non-local return. */
124 scm_gc_after_nonlocal_exit ();
126 /* FIXME: We know where the args will be on the stack; we could
127 avoid consing them. */
128 args
= scm_i_prompt_pop_abort_args_x (vp
);
130 /* Cdr past the continuation. */
131 args
= scm_cdr (args
);
133 return scm_apply_0 (handler
, args
);
136 res
= scm_call_0 (thunk
);
138 scm_dynstack_unwind_fluid (dynstack
, dynamic_state
);
139 scm_dynstack_pop (dynstack
);
145 default_exception_handler (SCM k
, SCM args
)
147 static int error_printing_error
= 0;
148 static int error_printing_fallback
= 0;
150 if (error_printing_fallback
)
151 fprintf (stderr
, "\nFailed to print exception.\n");
152 else if (error_printing_error
)
154 fprintf (stderr
, "\nError while printing exception:\n");
155 error_printing_fallback
= 1;
156 fprintf (stderr
, "Key: ");
157 scm_write (k
, scm_current_error_port ());
158 fprintf (stderr
, ", args: ");
159 scm_write (args
, scm_current_error_port ());
160 scm_newline (scm_current_error_port ());
164 fprintf (stderr
, "Uncaught exception:\n");
165 error_printing_error
= 1;
166 scm_handle_by_message (NULL
, k
, args
);
169 /* Normally we don't get here, because scm_handle_by_message will
171 fprintf (stderr
, "Aborting.\n");
175 /* A version of scm_abort_to_prompt_star that avoids the need to cons
176 "tag" to "args", because we might be out of memory. */
178 abort_to_prompt (SCM prompt_tag
, SCM tag
, SCM args
)
184 n
= scm_ilength (args
) + 1;
185 argv
= alloca (sizeof (SCM
)*n
);
187 for (i
= 1; i
< n
; i
++, args
= scm_cdr (args
))
188 argv
[i
] = scm_car (args
);
190 scm_c_abort (scm_the_vm (), prompt_tag
, n
, argv
, NULL
);
192 /* Oh, what, you're still here? The abort must have been reinstated. Actually,
193 that's quite impossible, given that we're already in C-land here, so...
200 throw_without_pre_unwind (SCM tag
, SCM args
)
204 /* This function is not only the boot implementation of "throw", it is
205 also called in response to resource allocation failures such as
206 stack-overflow or out-of-memory. For that reason we need to be
207 careful to avoid allocating memory. */
208 for (eh
= scm_fluid_ref (exception_handler_fluid
);
210 eh
= scm_c_vector_ref (eh
, 0))
212 SCM catch_key
, prompt_tag
;
214 catch_key
= scm_c_vector_ref (eh
, 1);
215 if (!scm_is_eq (catch_key
, SCM_BOOL_T
) && !scm_is_eq (catch_key
, tag
))
218 if (scm_is_true (scm_c_vector_ref (eh
, 3)))
220 const char *key_chars
;
222 if (scm_i_is_narrow_symbol (tag
))
223 key_chars
= scm_i_symbol_chars (tag
);
225 key_chars
= "(wide symbol)";
227 fprintf (stderr
, "Warning: Unwind-only `%s' exception; "
228 "skipping pre-unwind handler.\n", key_chars
);
231 prompt_tag
= scm_c_vector_ref (eh
, 2);
232 if (scm_is_true (prompt_tag
))
233 abort_to_prompt (prompt_tag
, tag
, args
);
236 default_exception_handler (tag
, args
);
237 return SCM_UNSPECIFIED
;
241 scm_catch (SCM key
, SCM thunk
, SCM handler
)
243 return catch (key
, thunk
, handler
, SCM_UNDEFINED
);
247 scm_catch_with_pre_unwind_handler (SCM key
, SCM thunk
, SCM handler
,
248 SCM pre_unwind_handler
)
250 return catch (key
, thunk
, handler
, pre_unwind_handler
);
254 scm_with_throw_handler (SCM key
, SCM thunk
, SCM handler
)
256 return catch (key
, thunk
, SCM_UNDEFINED
, handler
);
260 scm_throw (SCM key
, SCM args
)
262 return scm_apply_1 (scm_variable_ref (throw_var
), key
, args
);
267 /* Now some support for C bodies and catch handlers */
269 static scm_t_bits tc16_catch_closure
;
273 CATCH_CLOSURE_HANDLER
277 make_catch_body_closure (scm_t_catch_body body
, void *body_data
)
280 SCM_NEWSMOB2 (ret
, tc16_catch_closure
, body
, body_data
);
281 SCM_SET_SMOB_FLAGS (ret
, CATCH_CLOSURE_BODY
);
286 make_catch_handler_closure (scm_t_catch_handler handler
, void *handler_data
)
289 SCM_NEWSMOB2 (ret
, tc16_catch_closure
, handler
, handler_data
);
290 SCM_SET_SMOB_FLAGS (ret
, CATCH_CLOSURE_HANDLER
);
295 apply_catch_closure (SCM clo
, SCM args
)
297 void *data
= (void*)SCM_SMOB_DATA_2 (clo
);
299 switch (SCM_SMOB_FLAGS (clo
))
301 case CATCH_CLOSURE_BODY
:
303 scm_t_catch_body body
= (void*)SCM_SMOB_DATA (clo
);
306 case CATCH_CLOSURE_HANDLER
:
308 scm_t_catch_handler handler
= (void*)SCM_SMOB_DATA (clo
);
309 return handler (data
, scm_car (args
), scm_cdr (args
));
316 /* TAG is the catch tag. Typically, this is a symbol, but this
317 function doesn't actually care about that.
319 BODY is a pointer to a C function which runs the body of the catch;
320 this is the code you can throw from. We call it like this:
323 BODY_DATA is just the BODY_DATA argument we received; we pass it
324 through to BODY as its first argument. The caller can make
325 BODY_DATA point to anything useful that BODY might need.
327 HANDLER is a pointer to a C function to deal with a throw to TAG,
328 should one occur. We call it like this:
329 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
331 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
332 same idea as BODY_DATA above.
333 THROWN_TAG is the tag that the user threw to; usually this is
334 TAG, but it could be something else if TAG was #t (i.e., a
335 catch-all), or the user threw to a jmpbuf.
336 THROW_ARGS is the list of arguments the user passed to the THROW
337 function, after the tag.
339 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
340 is just a pointer we pass through to HANDLER. We don't actually
341 use either of those pointers otherwise ourselves. The idea is
342 that, if our caller wants to communicate something to BODY or
343 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
344 HANDLER can then use. Think of it as a way to make BODY and
345 HANDLER closures, not just functions; MUMBLE_DATA points to the
348 Of course, it's up to the caller to make sure that any data a
349 MUMBLE_DATA needs is protected from GC. A common way to do this is
350 to make MUMBLE_DATA a pointer to data stored in an automatic
351 structure variable; since the collector must scan the stack for
352 references anyway, this assures that any references in MUMBLE_DATA
356 scm_c_catch (SCM tag
,
357 scm_t_catch_body body
, void *body_data
,
358 scm_t_catch_handler handler
, void *handler_data
,
359 scm_t_catch_handler pre_unwind_handler
, void *pre_unwind_handler_data
)
361 SCM sbody
, shandler
, spre_unwind_handler
;
363 sbody
= make_catch_body_closure (body
, body_data
);
364 shandler
= make_catch_handler_closure (handler
, handler_data
);
365 if (pre_unwind_handler
)
366 spre_unwind_handler
= make_catch_handler_closure (pre_unwind_handler
,
367 pre_unwind_handler_data
);
369 spre_unwind_handler
= SCM_UNDEFINED
;
371 return scm_catch_with_pre_unwind_handler (tag
, sbody
, shandler
,
372 spre_unwind_handler
);
376 scm_internal_catch (SCM tag
,
377 scm_t_catch_body body
, void *body_data
,
378 scm_t_catch_handler handler
, void *handler_data
)
380 return scm_c_catch (tag
,
382 handler
, handler_data
,
388 scm_c_with_throw_handler (SCM tag
,
389 scm_t_catch_body body
,
391 scm_t_catch_handler handler
,
398 scm_c_issue_deprecation_warning
399 ("The LAZY_CATCH_P argument to `scm_c_with_throw_handler' is no longer.\n"
400 "supported. Instead the handler will be invoked from within the dynamic\n"
401 "context of the corresponding `throw'.\n"
402 "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
403 "Please modify your program to pass 0 as the LAZY_CATCH_P argument,\n"
404 "and adapt it (if necessary) to expect to be within the dynamic context\n"
407 sbody
= make_catch_body_closure (body
, body_data
);
408 shandler
= make_catch_handler_closure (handler
, handler_data
);
410 return scm_with_throw_handler (tag
, sbody
, shandler
);
414 /* body and handler functions for use with any of the above catch variants */
416 /* This is a body function you can pass to scm_internal_catch if you
417 want the body to be like Scheme's `catch' --- a thunk.
419 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
420 contains the Scheme procedure to invoke as the body, and the tag
424 scm_body_thunk (void *body_data
)
426 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
428 return scm_call_0 (c
->body_proc
);
432 /* This is a handler function you can pass to scm_internal_catch if
433 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
434 applies a handler procedure to (TAG ARGS ...).
436 If the user does a throw to this catch, this function runs a
437 handler procedure written in Scheme. HANDLER_DATA is a pointer to
438 an SCM variable holding the Scheme procedure object to invoke. It
439 ought to be a pointer to an automatic variable (i.e., one living on
440 the stack), or the procedure object should be otherwise protected
443 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
445 SCM
*handler_proc_p
= (SCM
*) handler_data
;
447 return scm_apply_1 (*handler_proc_p
, tag
, throw_args
);
450 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
451 catches all throws that the handler might emit itself. The handler
452 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
460 hbpca_body (void *body_data
)
462 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
463 return scm_apply_0 (data
->proc
, data
->args
);
467 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
469 SCM
*handler_proc_p
= (SCM
*) handler_data
;
470 struct hbpca_data data
;
471 data
.proc
= *handler_proc_p
;
472 data
.args
= scm_cons (tag
, throw_args
);
474 return scm_internal_catch (SCM_BOOL_T
,
476 scm_handle_by_message_noexit
, NULL
);
479 /* Derive the an exit status from the arguments to (quit ...). */
481 scm_exit_status (SCM args
)
483 if (scm_is_pair (args
))
485 SCM cqa
= SCM_CAR (args
);
487 if (scm_is_integer (cqa
))
488 return (scm_to_int (cqa
));
489 else if (scm_is_false (cqa
))
494 else if (scm_is_null (args
))
497 /* A type error. Strictly speaking we shouldn't get here. */
503 should_print_backtrace (SCM tag
, SCM stack
)
505 return SCM_BACKTRACE_P
506 && scm_is_true (stack
)
508 /* It's generally not useful to print backtraces for errors reading
509 or expanding code in these fallback catch statements. */
510 && !scm_is_eq (tag
, scm_from_latin1_symbol ("read-error"))
511 && !scm_is_eq (tag
, scm_from_latin1_symbol ("syntax-error"));
515 handler_message (void *handler_data
, SCM tag
, SCM args
)
519 p
= scm_current_error_port ();
520 /* Usually we get here via a throw to a catch-all. In that case
521 there is the throw frame active, and the catch closure, so narrow by
522 two frames. It is possible for a user to invoke
523 scm_handle_by_message directly, though, so it could be this
524 narrows too much. We'll have to see how this works out in
526 stack
= scm_make_stack (SCM_BOOL_T
, scm_list_1 (scm_from_int (2)));
527 frame
= scm_is_true (stack
) ? scm_stack_ref (stack
, SCM_INUM0
) : SCM_BOOL_F
;
529 if (should_print_backtrace (tag
, stack
))
531 scm_puts_unlocked ("Backtrace:\n", p
);
532 scm_display_backtrace_with_highlights (stack
, p
,
533 SCM_BOOL_F
, SCM_BOOL_F
,
538 scm_print_exception (p
, frame
, tag
, args
);
542 /* This is a handler function to use if you want scheme to print a
543 message and die. Useful for dealing with throws to uncaught keys
546 At boot time, we establish a catch-all that uses this as its handler.
547 1) If the user wants something different, they can use (catch #t
548 ...) to do what they like.
549 2) Outside the context of a read-eval-print loop, there isn't
550 anything else good to do; libguile should not assume the existence
551 of a read-eval-print loop.
552 3) Given that we shouldn't do anything complex, it's much more
553 robust to do it in C code.
555 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
556 message header to print; if zero, we use "guile" instead. That
557 text is followed by a colon, then the message described by ARGS. */
559 /* Dirk:FIXME:: The name of the function should make clear that the
560 * application gets terminated.
564 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
566 if (scm_is_true (scm_eq_p (tag
, scm_from_latin1_symbol ("quit"))))
567 exit (scm_exit_status (args
));
569 handler_message (handler_data
, tag
, args
);
570 scm_i_pthread_exit (NULL
);
572 /* this point not reached, but suppress gcc warning about no return value
573 in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
574 to be the case on cygwin for instance) */
579 /* This is just like scm_handle_by_message, but it doesn't exit; it
580 just returns #f. It's useful in cases where you don't really know
581 enough about the body to handle things in a better way, but don't
582 want to let throws fall off the bottom of the wind list. */
584 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
586 if (scm_is_true (scm_eq_p (tag
, scm_from_latin1_symbol ("quit"))))
587 exit (scm_exit_status (args
));
589 handler_message (handler_data
, tag
, args
);
596 scm_handle_by_throw (void *handler_data SCM_UNUSED
, SCM tag
, SCM args
)
598 scm_ithrow (tag
, args
, 1);
599 return SCM_UNSPECIFIED
; /* never returns */
603 scm_ithrow (SCM key
, SCM args
, int no_return SCM_UNUSED
)
605 return scm_throw (key
, args
);
608 SCM_SYMBOL (scm_stack_overflow_key
, "stack-overflow");
609 SCM_SYMBOL (scm_out_of_memory_key
, "out-of-memory");
611 static SCM stack_overflow_args
= SCM_BOOL_F
;
612 static SCM out_of_memory_args
= SCM_BOOL_F
;
614 /* Since these two functions may be called in response to resource
615 exhaustion, we have to avoid allocating memory. */
618 scm_report_stack_overflow (void)
620 if (scm_is_false (stack_overflow_args
))
622 throw_without_pre_unwind (scm_stack_overflow_key
, stack_overflow_args
);
629 scm_report_out_of_memory (void)
631 if (scm_is_false (out_of_memory_args
))
633 throw_without_pre_unwind (scm_out_of_memory_key
, out_of_memory_args
);
642 tc16_catch_closure
= scm_make_smob_type ("catch-closure", 0);
643 scm_set_smob_apply (tc16_catch_closure
, apply_catch_closure
, 0, 0, 1);
645 exception_handler_fluid
= scm_make_fluid_with_default (SCM_BOOL_F
);
646 /* This binding is later removed when the Scheme definitions of catch,
647 throw, and with-throw-handler are created in boot-9.scm. */
648 scm_c_define ("%exception-handler", exception_handler_fluid
);
650 scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0, catch));
651 throw_var
= scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1,
652 throw_without_pre_unwind
));
654 /* Arguments as if from:
656 scm_error (stack-overflow, NULL, "Stack overflow", #f, #f);
658 We build the arguments manually because we throw without running
659 pre-unwind handlers. (Pre-unwind handlers could rewind the
661 stack_overflow_args
= scm_list_4 (SCM_BOOL_F
,
662 scm_from_latin1_string ("Stack overflow"),
665 out_of_memory_args
= scm_list_4 (SCM_BOOL_F
,
666 scm_from_latin1_string ("Out of memory"),
670 #include "libguile/throw.x"