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
27 #include "libguile/_scm.h"
28 #include "libguile/smob.h"
29 #include "libguile/eval.h"
30 #include "libguile/eq.h"
31 #include "libguile/control.h"
32 #include "libguile/deprecation.h"
33 #include "libguile/backtrace.h"
34 #include "libguile/debug.h"
35 #include "libguile/stackchk.h"
36 #include "libguile/stacks.h"
37 #include "libguile/fluids.h"
38 #include "libguile/ports.h"
39 #include "libguile/validate.h"
40 #include "libguile/vm.h"
41 #include "libguile/throw.h"
42 #include "libguile/init.h"
43 #include "libguile/strings.h"
45 #include "libguile/private-options.h"
48 /* Pleasantly enough, the guts of catch are defined in Scheme, in terms
49 of prompt, abort, and the %exception-handler fluid. Check boot-9 for
52 Still, it's useful to be able to throw unwind-only exceptions from C,
53 for example so that we can recover from stack overflow. We also need
54 to have an implementation of catch and throw handy before boot time.
55 For that reason we have a parallel implementation of "catch" that
56 uses the same fluids here. Throws from C still call out to Scheme
57 though, so that pre-unwind handlers can be run. Getting the dynamic
58 environment right for pre-unwind handlers is tricky, and it's
59 important to have all of the implementation in one place.
61 All of these function names and prototypes carry a fair bit of historical
69 static SCM exception_handler_fluid
;
72 catch (SCM tag
, SCM thunk
, SCM handler
, SCM pre_unwind_handler
)
77 scm_t_dynstack
*dynstack
= &SCM_I_CURRENT_THREAD
->dynstack
;
78 SCM dynamic_state
= SCM_I_CURRENT_THREAD
->dynamic_state
;
79 scm_i_jmp_buf registers
;
80 scm_t_ptrdiff saved_stack_depth
;
82 if (!scm_is_eq (tag
, SCM_BOOL_T
) && !scm_is_symbol (tag
))
83 scm_wrong_type_arg ("catch", 1, tag
);
85 if (SCM_UNBNDP (handler
))
87 else if (!scm_is_true (scm_procedure_p (handler
)))
88 scm_wrong_type_arg ("catch", 3, handler
);
90 if (SCM_UNBNDP (pre_unwind_handler
))
91 pre_unwind_handler
= SCM_BOOL_F
;
92 else if (!scm_is_true (scm_procedure_p (pre_unwind_handler
)))
93 scm_wrong_type_arg ("catch", 4, pre_unwind_handler
);
95 prompt_tag
= scm_cons (SCM_INUM0
, SCM_EOL
);
97 eh
= scm_c_make_vector (4, SCM_BOOL_F
);
98 scm_c_vector_set_x (eh
, 0, scm_fluid_ref (exception_handler_fluid
));
99 scm_c_vector_set_x (eh
, 1, tag
);
100 scm_c_vector_set_x (eh
, 2, prompt_tag
);
101 scm_c_vector_set_x (eh
, 3, pre_unwind_handler
);
104 saved_stack_depth
= vp
->sp
- vp
->stack_base
;
106 /* Push the prompt and exception handler onto the dynamic stack. */
107 scm_dynstack_push_prompt (dynstack
,
108 SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
109 | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS
,
111 vp
->fp
- vp
->stack_base
,
115 scm_dynstack_push_fluid (dynstack
, exception_handler_fluid
, eh
,
118 if (SCM_I_SETJMP (registers
))
120 /* A non-local return. */
122 /* FIXME: We know where the args will be on the stack; we could
123 avoid consing them. */
124 SCM args
= scm_i_prompt_pop_abort_args_x (vp
);
126 /* Cdr past the continuation. */
127 args
= scm_cdr (args
);
129 return scm_apply_0 (handler
, args
);
132 res
= scm_call_0 (thunk
);
134 scm_dynstack_unwind_fluid (dynstack
, dynamic_state
);
135 scm_dynstack_pop (dynstack
);
141 default_exception_handler (SCM k
, SCM args
)
143 static int error_printing_error
= 0;
144 static int error_printing_fallback
= 0;
146 if (error_printing_fallback
)
147 fprintf (stderr
, "\nFailed to print exception.\n");
148 else if (error_printing_error
)
150 fprintf (stderr
, "\nError while printing exception:\n");
151 error_printing_fallback
= 1;
152 fprintf (stderr
, "Key: ");
153 scm_write (k
, scm_current_error_port ());
154 fprintf (stderr
, ", args: ");
155 scm_write (args
, scm_current_error_port ());
156 scm_newline (scm_current_error_port ());
160 fprintf (stderr
, "Uncaught exception:\n");
161 error_printing_error
= 1;
162 scm_handle_by_message (NULL
, k
, args
);
165 /* Normally we don't get here, because scm_handle_by_message will
167 fprintf (stderr
, "Aborting.\n");
172 throw_without_pre_unwind (SCM tag
, SCM args
)
176 for (eh
= scm_fluid_ref (exception_handler_fluid
);
178 eh
= scm_c_vector_ref (eh
, 0))
180 SCM catch_key
, prompt_tag
;
182 catch_key
= scm_c_vector_ref (eh
, 1);
183 if (!scm_is_eq (catch_key
, SCM_BOOL_T
) && !scm_is_eq (catch_key
, tag
))
186 if (scm_is_true (scm_c_vector_ref (eh
, 3)))
187 fprintf (stderr
, "\nWarning: unwind-only exception, perhaps due to "
188 "stack overflow; not running pre-unwind handlers.");
190 prompt_tag
= scm_c_vector_ref (eh
, 2);
191 if (scm_is_true (prompt_tag
))
192 scm_abort_to_prompt_star (prompt_tag
, scm_cons (tag
, args
));
195 default_exception_handler (tag
, args
);
196 return SCM_UNSPECIFIED
;
200 scm_catch (SCM key
, SCM thunk
, SCM handler
)
202 return catch (key
, thunk
, handler
, SCM_UNDEFINED
);
206 scm_catch_with_pre_unwind_handler (SCM key
, SCM thunk
, SCM handler
,
207 SCM pre_unwind_handler
)
209 return catch (key
, thunk
, handler
, pre_unwind_handler
);
213 scm_with_throw_handler (SCM key
, SCM thunk
, SCM handler
)
215 return catch (key
, thunk
, SCM_UNDEFINED
, handler
);
219 scm_throw (SCM key
, SCM args
)
221 return scm_apply_1 (scm_variable_ref (throw_var
), key
, args
);
226 /* Now some support for C bodies and catch handlers */
228 static scm_t_bits tc16_catch_closure
;
232 CATCH_CLOSURE_HANDLER
236 make_catch_body_closure (scm_t_catch_body body
, void *body_data
)
239 SCM_NEWSMOB2 (ret
, tc16_catch_closure
, body
, body_data
);
240 SCM_SET_SMOB_FLAGS (ret
, CATCH_CLOSURE_BODY
);
245 make_catch_handler_closure (scm_t_catch_handler handler
, void *handler_data
)
248 SCM_NEWSMOB2 (ret
, tc16_catch_closure
, handler
, handler_data
);
249 SCM_SET_SMOB_FLAGS (ret
, CATCH_CLOSURE_HANDLER
);
254 apply_catch_closure (SCM clo
, SCM args
)
256 void *data
= (void*)SCM_SMOB_DATA_2 (clo
);
258 switch (SCM_SMOB_FLAGS (clo
))
260 case CATCH_CLOSURE_BODY
:
262 scm_t_catch_body body
= (void*)SCM_SMOB_DATA (clo
);
265 case CATCH_CLOSURE_HANDLER
:
267 scm_t_catch_handler handler
= (void*)SCM_SMOB_DATA (clo
);
268 return handler (data
, scm_car (args
), scm_cdr (args
));
275 /* TAG is the catch tag. Typically, this is a symbol, but this
276 function doesn't actually care about that.
278 BODY is a pointer to a C function which runs the body of the catch;
279 this is the code you can throw from. We call it like this:
282 BODY_DATA is just the BODY_DATA argument we received; we pass it
283 through to BODY as its first argument. The caller can make
284 BODY_DATA point to anything useful that BODY might need.
286 HANDLER is a pointer to a C function to deal with a throw to TAG,
287 should one occur. We call it like this:
288 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
290 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
291 same idea as BODY_DATA above.
292 THROWN_TAG is the tag that the user threw to; usually this is
293 TAG, but it could be something else if TAG was #t (i.e., a
294 catch-all), or the user threw to a jmpbuf.
295 THROW_ARGS is the list of arguments the user passed to the THROW
296 function, after the tag.
298 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
299 is just a pointer we pass through to HANDLER. We don't actually
300 use either of those pointers otherwise ourselves. The idea is
301 that, if our caller wants to communicate something to BODY or
302 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
303 HANDLER can then use. Think of it as a way to make BODY and
304 HANDLER closures, not just functions; MUMBLE_DATA points to the
307 Of course, it's up to the caller to make sure that any data a
308 MUMBLE_DATA needs is protected from GC. A common way to do this is
309 to make MUMBLE_DATA a pointer to data stored in an automatic
310 structure variable; since the collector must scan the stack for
311 references anyway, this assures that any references in MUMBLE_DATA
315 scm_c_catch (SCM tag
,
316 scm_t_catch_body body
, void *body_data
,
317 scm_t_catch_handler handler
, void *handler_data
,
318 scm_t_catch_handler pre_unwind_handler
, void *pre_unwind_handler_data
)
320 SCM sbody
, shandler
, spre_unwind_handler
;
322 sbody
= make_catch_body_closure (body
, body_data
);
323 shandler
= make_catch_handler_closure (handler
, handler_data
);
324 if (pre_unwind_handler
)
325 spre_unwind_handler
= make_catch_handler_closure (pre_unwind_handler
,
326 pre_unwind_handler_data
);
328 spre_unwind_handler
= SCM_UNDEFINED
;
330 return scm_catch_with_pre_unwind_handler (tag
, sbody
, shandler
,
331 spre_unwind_handler
);
335 scm_internal_catch (SCM tag
,
336 scm_t_catch_body body
, void *body_data
,
337 scm_t_catch_handler handler
, void *handler_data
)
339 return scm_c_catch (tag
,
341 handler
, handler_data
,
347 scm_c_with_throw_handler (SCM tag
,
348 scm_t_catch_body body
,
350 scm_t_catch_handler handler
,
357 scm_c_issue_deprecation_warning
358 ("The LAZY_CATCH_P argument to `scm_c_with_throw_handler' is no longer.\n"
359 "supported. Instead the handler will be invoked from within the dynamic\n"
360 "context of the corresponding `throw'.\n"
361 "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
362 "Please modify your program to pass 0 as the LAZY_CATCH_P argument,\n"
363 "and adapt it (if necessary) to expect to be within the dynamic context\n"
366 sbody
= make_catch_body_closure (body
, body_data
);
367 shandler
= make_catch_handler_closure (handler
, handler_data
);
369 return scm_with_throw_handler (tag
, sbody
, shandler
);
373 /* body and handler functions for use with any of the above catch variants */
375 /* This is a body function you can pass to scm_internal_catch if you
376 want the body to be like Scheme's `catch' --- a thunk.
378 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
379 contains the Scheme procedure to invoke as the body, and the tag
383 scm_body_thunk (void *body_data
)
385 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
387 return scm_call_0 (c
->body_proc
);
391 /* This is a handler function you can pass to scm_internal_catch if
392 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
393 applies a handler procedure to (TAG ARGS ...).
395 If the user does a throw to this catch, this function runs a
396 handler procedure written in Scheme. HANDLER_DATA is a pointer to
397 an SCM variable holding the Scheme procedure object to invoke. It
398 ought to be a pointer to an automatic variable (i.e., one living on
399 the stack), or the procedure object should be otherwise protected
402 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
404 SCM
*handler_proc_p
= (SCM
*) handler_data
;
406 return scm_apply_1 (*handler_proc_p
, tag
, throw_args
);
409 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
410 catches all throws that the handler might emit itself. The handler
411 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
419 hbpca_body (void *body_data
)
421 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
422 return scm_apply_0 (data
->proc
, data
->args
);
426 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
428 SCM
*handler_proc_p
= (SCM
*) handler_data
;
429 struct hbpca_data data
;
430 data
.proc
= *handler_proc_p
;
431 data
.args
= scm_cons (tag
, throw_args
);
433 return scm_internal_catch (SCM_BOOL_T
,
435 scm_handle_by_message_noexit
, NULL
);
438 /* Derive the an exit status from the arguments to (quit ...). */
440 scm_exit_status (SCM args
)
442 if (scm_is_pair (args
))
444 SCM cqa
= SCM_CAR (args
);
446 if (scm_is_integer (cqa
))
447 return (scm_to_int (cqa
));
448 else if (scm_is_false (cqa
))
453 else if (scm_is_null (args
))
456 /* A type error. Strictly speaking we shouldn't get here. */
462 should_print_backtrace (SCM tag
, SCM stack
)
464 return SCM_BACKTRACE_P
465 && scm_is_true (stack
)
467 /* It's generally not useful to print backtraces for errors reading
468 or expanding code in these fallback catch statements. */
469 && !scm_is_eq (tag
, scm_from_latin1_symbol ("read-error"))
470 && !scm_is_eq (tag
, scm_from_latin1_symbol ("syntax-error"));
474 handler_message (void *handler_data
, SCM tag
, SCM args
)
478 p
= scm_current_error_port ();
479 /* Usually we get here via a throw to a catch-all. In that case
480 there is the throw frame active, and the catch closure, so narrow by
481 two frames. It is possible for a user to invoke
482 scm_handle_by_message directly, though, so it could be this
483 narrows too much. We'll have to see how this works out in
485 stack
= scm_make_stack (SCM_BOOL_T
, scm_list_1 (scm_from_int (2)));
486 frame
= scm_is_true (stack
) ? scm_stack_ref (stack
, SCM_INUM0
) : SCM_BOOL_F
;
488 if (should_print_backtrace (tag
, stack
))
490 scm_puts_unlocked ("Backtrace:\n", p
);
491 scm_display_backtrace_with_highlights (stack
, p
,
492 SCM_BOOL_F
, SCM_BOOL_F
,
497 scm_print_exception (p
, frame
, tag
, args
);
501 /* This is a handler function to use if you want scheme to print a
502 message and die. Useful for dealing with throws to uncaught keys
505 At boot time, we establish a catch-all that uses this as its handler.
506 1) If the user wants something different, they can use (catch #t
507 ...) to do what they like.
508 2) Outside the context of a read-eval-print loop, there isn't
509 anything else good to do; libguile should not assume the existence
510 of a read-eval-print loop.
511 3) Given that we shouldn't do anything complex, it's much more
512 robust to do it in C code.
514 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
515 message header to print; if zero, we use "guile" instead. That
516 text is followed by a colon, then the message described by ARGS. */
518 /* Dirk:FIXME:: The name of the function should make clear that the
519 * application gets terminated.
523 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
525 if (scm_is_true (scm_eq_p (tag
, scm_from_latin1_symbol ("quit"))))
526 exit (scm_exit_status (args
));
528 handler_message (handler_data
, tag
, args
);
529 scm_i_pthread_exit (NULL
);
531 /* this point not reached, but suppress gcc warning about no return value
532 in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
533 to be the case on cygwin for instance) */
538 /* This is just like scm_handle_by_message, but it doesn't exit; it
539 just returns #f. It's useful in cases where you don't really know
540 enough about the body to handle things in a better way, but don't
541 want to let throws fall off the bottom of the wind list. */
543 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
545 if (scm_is_true (scm_eq_p (tag
, scm_from_latin1_symbol ("quit"))))
546 exit (scm_exit_status (args
));
548 handler_message (handler_data
, tag
, args
);
555 scm_handle_by_throw (void *handler_data SCM_UNUSED
, SCM tag
, SCM args
)
557 scm_ithrow (tag
, args
, 1);
558 return SCM_UNSPECIFIED
; /* never returns */
562 scm_ithrow (SCM key
, SCM args
, int no_return SCM_UNUSED
)
564 return scm_throw (key
, args
);
567 SCM_SYMBOL (scm_stack_overflow_key
, "stack-overflow");
570 scm_report_stack_overflow (void)
572 /* Arguments as if from:
574 scm_error (stack-overflow, NULL, "Stack overflow", #f, #f);
576 We build the arguments manually because we throw without running
577 pre-unwind handlers. (Pre-unwind handlers could rewind the
579 SCM args
= scm_list_4 (SCM_BOOL_F
,
580 scm_from_latin1_string ("Stack overflow"),
583 throw_without_pre_unwind (scm_stack_overflow_key
, args
);
592 tc16_catch_closure
= scm_make_smob_type ("catch-closure", 0);
593 scm_set_smob_apply (tc16_catch_closure
, apply_catch_closure
, 0, 0, 1);
595 exception_handler_fluid
= scm_make_fluid_with_default (SCM_BOOL_F
);
596 /* This binding is later removed when the Scheme definitions of catch,
597 throw, and with-throw-handler are created in boot-9.scm. */
598 scm_c_define ("%exception-handler", exception_handler_fluid
);
600 scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0, catch));
601 throw_var
= scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1,
602 throw_without_pre_unwind
));
604 #include "libguile/throw.x"