1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012 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 of
49 prompt, abort, and the %exception-handler fluid. This file just provides
50 shims so that it's easy to have catch functionality from C.
52 All of these function names and prototypes carry a fair bit of historical
56 #define CACHE_VAR(var,name) \
57 static SCM var = SCM_BOOL_F; \
58 if (scm_is_false (var)) \
60 var = scm_module_variable (scm_the_root_module (), \
61 scm_from_latin1_symbol (name)); \
62 if (scm_is_false (var)) \
69 scm_catch (SCM key
, SCM thunk
, SCM handler
)
71 CACHE_VAR (var
, "catch");
73 return scm_call_3 (scm_variable_ref (var
), key
, thunk
, handler
);
77 scm_catch_with_pre_unwind_handler (SCM key
, SCM thunk
, SCM handler
,
78 SCM pre_unwind_handler
)
80 if (SCM_UNBNDP (pre_unwind_handler
))
81 return scm_catch (key
, thunk
, handler
);
84 CACHE_VAR (var
, "catch");
86 return scm_call_4 (scm_variable_ref (var
), key
, thunk
, handler
,
92 scm_with_throw_handler (SCM key
, SCM thunk
, SCM handler
)
94 CACHE_VAR (var
, "with-throw-handler");
96 return scm_call_3 (scm_variable_ref (var
), key
, thunk
, handler
);
100 scm_throw (SCM key
, SCM args
)
102 CACHE_VAR (var
, "throw");
104 return scm_apply_1 (scm_variable_ref (var
), key
, args
);
109 /* Now some support for C bodies and catch handlers */
111 static scm_t_bits tc16_catch_closure
;
115 CATCH_CLOSURE_HANDLER
119 make_catch_body_closure (scm_t_catch_body body
, void *body_data
)
122 SCM_NEWSMOB2 (ret
, tc16_catch_closure
, body
, body_data
);
123 SCM_SET_SMOB_FLAGS (ret
, CATCH_CLOSURE_BODY
);
128 make_catch_handler_closure (scm_t_catch_handler handler
, void *handler_data
)
131 SCM_NEWSMOB2 (ret
, tc16_catch_closure
, handler
, handler_data
);
132 SCM_SET_SMOB_FLAGS (ret
, CATCH_CLOSURE_HANDLER
);
137 apply_catch_closure (SCM clo
, SCM args
)
139 void *data
= (void*)SCM_SMOB_DATA_2 (clo
);
141 switch (SCM_SMOB_FLAGS (clo
))
143 case CATCH_CLOSURE_BODY
:
145 scm_t_catch_body body
= (void*)SCM_SMOB_DATA (clo
);
148 case CATCH_CLOSURE_HANDLER
:
150 scm_t_catch_handler handler
= (void*)SCM_SMOB_DATA (clo
);
151 return handler (data
, scm_car (args
), scm_cdr (args
));
158 /* TAG is the catch tag. Typically, this is a symbol, but this
159 function doesn't actually care about that.
161 BODY is a pointer to a C function which runs the body of the catch;
162 this is the code you can throw from. We call it like this:
165 BODY_DATA is just the BODY_DATA argument we received; we pass it
166 through to BODY as its first argument. The caller can make
167 BODY_DATA point to anything useful that BODY might need.
169 HANDLER is a pointer to a C function to deal with a throw to TAG,
170 should one occur. We call it like this:
171 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
173 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
174 same idea as BODY_DATA above.
175 THROWN_TAG is the tag that the user threw to; usually this is
176 TAG, but it could be something else if TAG was #t (i.e., a
177 catch-all), or the user threw to a jmpbuf.
178 THROW_ARGS is the list of arguments the user passed to the THROW
179 function, after the tag.
181 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
182 is just a pointer we pass through to HANDLER. We don't actually
183 use either of those pointers otherwise ourselves. The idea is
184 that, if our caller wants to communicate something to BODY or
185 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
186 HANDLER can then use. Think of it as a way to make BODY and
187 HANDLER closures, not just functions; MUMBLE_DATA points to the
190 Of course, it's up to the caller to make sure that any data a
191 MUMBLE_DATA needs is protected from GC. A common way to do this is
192 to make MUMBLE_DATA a pointer to data stored in an automatic
193 structure variable; since the collector must scan the stack for
194 references anyway, this assures that any references in MUMBLE_DATA
198 scm_c_catch (SCM tag
,
199 scm_t_catch_body body
, void *body_data
,
200 scm_t_catch_handler handler
, void *handler_data
,
201 scm_t_catch_handler pre_unwind_handler
, void *pre_unwind_handler_data
)
203 SCM sbody
, shandler
, spre_unwind_handler
;
205 sbody
= make_catch_body_closure (body
, body_data
);
206 shandler
= make_catch_handler_closure (handler
, handler_data
);
207 if (pre_unwind_handler
)
208 spre_unwind_handler
= make_catch_handler_closure (pre_unwind_handler
,
209 pre_unwind_handler_data
);
211 spre_unwind_handler
= SCM_UNDEFINED
;
213 return scm_catch_with_pre_unwind_handler (tag
, sbody
, shandler
,
214 spre_unwind_handler
);
218 scm_internal_catch (SCM tag
,
219 scm_t_catch_body body
, void *body_data
,
220 scm_t_catch_handler handler
, void *handler_data
)
222 return scm_c_catch (tag
,
224 handler
, handler_data
,
230 scm_c_with_throw_handler (SCM tag
,
231 scm_t_catch_body body
,
233 scm_t_catch_handler handler
,
240 scm_c_issue_deprecation_warning
241 ("The LAZY_CATCH_P argument to `scm_c_with_throw_handler' is no longer.\n"
242 "supported. Instead the handler will be invoked from within the dynamic\n"
243 "context of the corresponding `throw'.\n"
244 "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
245 "Please modify your program to pass 0 as the LAZY_CATCH_P argument,\n"
246 "and adapt it (if necessary) to expect to be within the dynamic context\n"
249 sbody
= make_catch_body_closure (body
, body_data
);
250 shandler
= make_catch_handler_closure (handler
, handler_data
);
252 return scm_with_throw_handler (tag
, sbody
, shandler
);
256 /* body and handler functions for use with any of the above catch variants */
258 /* This is a body function you can pass to scm_internal_catch if you
259 want the body to be like Scheme's `catch' --- a thunk.
261 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
262 contains the Scheme procedure to invoke as the body, and the tag
266 scm_body_thunk (void *body_data
)
268 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
270 return scm_call_0 (c
->body_proc
);
274 /* This is a handler function you can pass to scm_internal_catch if
275 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
276 applies a handler procedure to (TAG ARGS ...).
278 If the user does a throw to this catch, this function runs a
279 handler procedure written in Scheme. HANDLER_DATA is a pointer to
280 an SCM variable holding the Scheme procedure object to invoke. It
281 ought to be a pointer to an automatic variable (i.e., one living on
282 the stack), or the procedure object should be otherwise protected
285 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
287 SCM
*handler_proc_p
= (SCM
*) handler_data
;
289 return scm_apply_1 (*handler_proc_p
, tag
, throw_args
);
292 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
293 catches all throws that the handler might emit itself. The handler
294 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
302 hbpca_body (void *body_data
)
304 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
305 return scm_apply_0 (data
->proc
, data
->args
);
309 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
311 SCM
*handler_proc_p
= (SCM
*) handler_data
;
312 struct hbpca_data data
;
313 data
.proc
= *handler_proc_p
;
314 data
.args
= scm_cons (tag
, throw_args
);
316 return scm_internal_catch (SCM_BOOL_T
,
318 scm_handle_by_message_noexit
, NULL
);
321 /* Derive the an exit status from the arguments to (quit ...). */
323 scm_exit_status (SCM args
)
325 if (scm_is_pair (args
))
327 SCM cqa
= SCM_CAR (args
);
329 if (scm_is_integer (cqa
))
330 return (scm_to_int (cqa
));
331 else if (scm_is_false (cqa
))
336 else if (scm_is_null (args
))
339 /* A type error. Strictly speaking we shouldn't get here. */
345 should_print_backtrace (SCM tag
, SCM stack
)
347 return SCM_BACKTRACE_P
348 && scm_is_true (stack
)
350 /* It's generally not useful to print backtraces for errors reading
351 or expanding code in these fallback catch statements. */
352 && !scm_is_eq (tag
, scm_from_latin1_symbol ("read-error"))
353 && !scm_is_eq (tag
, scm_from_latin1_symbol ("syntax-error"));
357 handler_message (void *handler_data
, SCM tag
, SCM args
)
361 p
= scm_current_error_port ();
362 /* Usually we get here via a throw to a catch-all. In that case
363 there is the throw frame active, and the catch closure, so narrow by
364 two frames. It is possible for a user to invoke
365 scm_handle_by_message directly, though, so it could be this
366 narrows too much. We'll have to see how this works out in
368 stack
= scm_make_stack (SCM_BOOL_T
, scm_list_1 (scm_from_int (2)));
369 frame
= scm_is_true (stack
) ? scm_stack_ref (stack
, SCM_INUM0
) : SCM_BOOL_F
;
371 if (should_print_backtrace (tag
, stack
))
373 scm_puts_unlocked ("Backtrace:\n", p
);
374 scm_display_backtrace_with_highlights (stack
, p
,
375 SCM_BOOL_F
, SCM_BOOL_F
,
380 scm_print_exception (p
, frame
, tag
, args
);
384 /* This is a handler function to use if you want scheme to print a
385 message and die. Useful for dealing with throws to uncaught keys
388 At boot time, we establish a catch-all that uses this as its handler.
389 1) If the user wants something different, they can use (catch #t
390 ...) to do what they like.
391 2) Outside the context of a read-eval-print loop, there isn't
392 anything else good to do; libguile should not assume the existence
393 of a read-eval-print loop.
394 3) Given that we shouldn't do anything complex, it's much more
395 robust to do it in C code.
397 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
398 message header to print; if zero, we use "guile" instead. That
399 text is followed by a colon, then the message described by ARGS. */
401 /* Dirk:FIXME:: The name of the function should make clear that the
402 * application gets terminated.
406 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
408 if (scm_is_true (scm_eq_p (tag
, scm_from_latin1_symbol ("quit"))))
409 exit (scm_exit_status (args
));
411 handler_message (handler_data
, tag
, args
);
412 scm_i_pthread_exit (NULL
);
414 /* this point not reached, but suppress gcc warning about no return value
415 in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
416 to be the case on cygwin for instance) */
421 /* This is just like scm_handle_by_message, but it doesn't exit; it
422 just returns #f. It's useful in cases where you don't really know
423 enough about the body to handle things in a better way, but don't
424 want to let throws fall off the bottom of the wind list. */
426 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
428 if (scm_is_true (scm_eq_p (tag
, scm_from_latin1_symbol ("quit"))))
429 exit (scm_exit_status (args
));
431 handler_message (handler_data
, tag
, args
);
438 scm_handle_by_throw (void *handler_data SCM_UNUSED
, SCM tag
, SCM args
)
440 scm_ithrow (tag
, args
, 1);
441 return SCM_UNSPECIFIED
; /* never returns */
445 scm_ithrow (SCM key
, SCM args
, int noreturn SCM_UNUSED
)
447 return scm_throw (key
, args
);
450 /* Unfortunately we have to support catch and throw before boot-9 has, um,
451 booted. So here are lame versions, which will get replaced with their scheme
454 SCM_SYMBOL (sym_pre_init_catch_tag
, "%pre-init-catch-tag");
457 pre_init_catch (SCM tag
, SCM thunk
, SCM handler
, SCM pre_unwind_handler
)
459 volatile SCM vm
, v_handler
;
461 scm_t_dynstack
*dynstack
= &SCM_I_CURRENT_THREAD
->dynstack
;
462 scm_i_jmp_buf registers
;
464 /* Only handle catch-alls without pre-unwind handlers */
465 if (!SCM_UNBNDP (pre_unwind_handler
))
467 if (scm_is_false (scm_eqv_p (tag
, SCM_BOOL_T
)))
470 /* These two are volatile, so we know we can access them after a
471 nonlocal return to the setjmp. */
475 /* Push the prompt onto the dynamic stack. */
476 scm_dynstack_push_prompt (dynstack
,
477 SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
,
478 sym_pre_init_catch_tag
,
479 SCM_VM_DATA (vm
)->fp
,
480 SCM_VM_DATA (vm
)->sp
,
481 SCM_VM_DATA (vm
)->ip
,
484 if (SCM_I_SETJMP (registers
))
487 SCM args
= scm_i_prompt_pop_abort_args_x (vm
);
488 /* cdr past the continuation */
489 return scm_apply_0 (v_handler
, scm_cdr (args
));
492 res
= scm_call_0 (thunk
);
493 scm_dynstack_pop (dynstack
);
499 find_pre_init_catch (void)
501 if (scm_dynstack_find_prompt (&SCM_I_CURRENT_THREAD
->dynstack
,
502 sym_pre_init_catch_tag
,
503 NULL
, NULL
, NULL
, NULL
, NULL
))
510 pre_init_throw (SCM k
, SCM args
)
512 if (find_pre_init_catch ())
513 return scm_at_abort (sym_pre_init_catch_tag
, scm_cons (k
, args
));
516 static int error_printing_error
= 0;
517 static int error_printing_fallback
= 0;
519 if (error_printing_fallback
)
520 fprintf (stderr
, "\nFailed to print exception.\n");
521 else if (error_printing_error
)
523 fprintf (stderr
, "\nError while printing exception:\n");
524 error_printing_fallback
= 1;
525 fprintf (stderr
, "Key: ");
526 scm_write (k
, scm_current_error_port ());
527 fprintf (stderr
, ", args: ");
528 scm_write (args
, scm_current_error_port ());
529 scm_newline (scm_current_error_port ());
533 fprintf (stderr
, "Throw without catch before boot:\n");
534 error_printing_error
= 1;
535 scm_handle_by_message_noexit (NULL
, k
, args
);
538 fprintf (stderr
, "Aborting.\n");
540 return SCM_BOOL_F
; /* not reached */
547 tc16_catch_closure
= scm_make_smob_type ("catch-closure", 0);
548 scm_set_smob_apply (tc16_catch_closure
, apply_catch_closure
, 0, 0, 1);
550 scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0, pre_init_catch
));
551 scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1, pre_init_throw
));
553 #include "libguile/throw.x"