1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 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
58 static SCM catch_var
, throw_var
, with_throw_handler_var
;
61 scm_catch (SCM key
, SCM thunk
, SCM handler
)
63 return scm_call_3 (scm_variable_ref (catch_var
), key
, thunk
, handler
);
67 scm_catch_with_pre_unwind_handler (SCM key
, SCM thunk
, SCM handler
,
68 SCM pre_unwind_handler
)
70 if (SCM_UNBNDP (pre_unwind_handler
))
71 return scm_catch (key
, thunk
, handler
);
73 return scm_call_4 (scm_variable_ref (catch_var
), key
, thunk
, handler
,
78 init_with_throw_handler_var (void)
80 with_throw_handler_var
81 = scm_module_variable (scm_the_root_module (),
82 scm_from_latin1_symbol ("with-throw-handler"));
86 scm_with_throw_handler (SCM key
, SCM thunk
, SCM handler
)
88 static scm_i_pthread_once_t once
= SCM_I_PTHREAD_ONCE_INIT
;
89 scm_i_pthread_once (&once
, init_with_throw_handler_var
);
91 return scm_call_3 (scm_variable_ref (with_throw_handler_var
),
96 scm_throw (SCM key
, SCM args
)
98 return scm_apply_1 (scm_variable_ref (throw_var
), key
, args
);
103 /* Now some support for C bodies and catch handlers */
105 static scm_t_bits tc16_catch_closure
;
109 CATCH_CLOSURE_HANDLER
113 make_catch_body_closure (scm_t_catch_body body
, void *body_data
)
116 SCM_NEWSMOB2 (ret
, tc16_catch_closure
, body
, body_data
);
117 SCM_SET_SMOB_FLAGS (ret
, CATCH_CLOSURE_BODY
);
122 make_catch_handler_closure (scm_t_catch_handler handler
, void *handler_data
)
125 SCM_NEWSMOB2 (ret
, tc16_catch_closure
, handler
, handler_data
);
126 SCM_SET_SMOB_FLAGS (ret
, CATCH_CLOSURE_HANDLER
);
131 apply_catch_closure (SCM clo
, SCM args
)
133 void *data
= (void*)SCM_SMOB_DATA_2 (clo
);
135 switch (SCM_SMOB_FLAGS (clo
))
137 case CATCH_CLOSURE_BODY
:
139 scm_t_catch_body body
= (void*)SCM_SMOB_DATA (clo
);
142 case CATCH_CLOSURE_HANDLER
:
144 scm_t_catch_handler handler
= (void*)SCM_SMOB_DATA (clo
);
145 return handler (data
, scm_car (args
), scm_cdr (args
));
152 /* TAG is the catch tag. Typically, this is a symbol, but this
153 function doesn't actually care about that.
155 BODY is a pointer to a C function which runs the body of the catch;
156 this is the code you can throw from. We call it like this:
159 BODY_DATA is just the BODY_DATA argument we received; we pass it
160 through to BODY as its first argument. The caller can make
161 BODY_DATA point to anything useful that BODY might need.
163 HANDLER is a pointer to a C function to deal with a throw to TAG,
164 should one occur. We call it like this:
165 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
167 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
168 same idea as BODY_DATA above.
169 THROWN_TAG is the tag that the user threw to; usually this is
170 TAG, but it could be something else if TAG was #t (i.e., a
171 catch-all), or the user threw to a jmpbuf.
172 THROW_ARGS is the list of arguments the user passed to the THROW
173 function, after the tag.
175 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
176 is just a pointer we pass through to HANDLER. We don't actually
177 use either of those pointers otherwise ourselves. The idea is
178 that, if our caller wants to communicate something to BODY or
179 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
180 HANDLER can then use. Think of it as a way to make BODY and
181 HANDLER closures, not just functions; MUMBLE_DATA points to the
184 Of course, it's up to the caller to make sure that any data a
185 MUMBLE_DATA needs is protected from GC. A common way to do this is
186 to make MUMBLE_DATA a pointer to data stored in an automatic
187 structure variable; since the collector must scan the stack for
188 references anyway, this assures that any references in MUMBLE_DATA
192 scm_c_catch (SCM tag
,
193 scm_t_catch_body body
, void *body_data
,
194 scm_t_catch_handler handler
, void *handler_data
,
195 scm_t_catch_handler pre_unwind_handler
, void *pre_unwind_handler_data
)
197 SCM sbody
, shandler
, spre_unwind_handler
;
199 sbody
= make_catch_body_closure (body
, body_data
);
200 shandler
= make_catch_handler_closure (handler
, handler_data
);
201 if (pre_unwind_handler
)
202 spre_unwind_handler
= make_catch_handler_closure (pre_unwind_handler
,
203 pre_unwind_handler_data
);
205 spre_unwind_handler
= SCM_UNDEFINED
;
207 return scm_catch_with_pre_unwind_handler (tag
, sbody
, shandler
,
208 spre_unwind_handler
);
212 scm_internal_catch (SCM tag
,
213 scm_t_catch_body body
, void *body_data
,
214 scm_t_catch_handler handler
, void *handler_data
)
216 return scm_c_catch (tag
,
218 handler
, handler_data
,
224 scm_c_with_throw_handler (SCM tag
,
225 scm_t_catch_body body
,
227 scm_t_catch_handler handler
,
234 scm_c_issue_deprecation_warning
235 ("The LAZY_CATCH_P argument to `scm_c_with_throw_handler' is no longer.\n"
236 "supported. Instead the handler will be invoked from within the dynamic\n"
237 "context of the corresponding `throw'.\n"
238 "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
239 "Please modify your program to pass 0 as the LAZY_CATCH_P argument,\n"
240 "and adapt it (if necessary) to expect to be within the dynamic context\n"
243 sbody
= make_catch_body_closure (body
, body_data
);
244 shandler
= make_catch_handler_closure (handler
, handler_data
);
246 return scm_with_throw_handler (tag
, sbody
, shandler
);
250 /* body and handler functions for use with any of the above catch variants */
252 /* This is a body function you can pass to scm_internal_catch if you
253 want the body to be like Scheme's `catch' --- a thunk.
255 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
256 contains the Scheme procedure to invoke as the body, and the tag
260 scm_body_thunk (void *body_data
)
262 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
264 return scm_call_0 (c
->body_proc
);
268 /* This is a handler function you can pass to scm_internal_catch if
269 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
270 applies a handler procedure to (TAG ARGS ...).
272 If the user does a throw to this catch, this function runs a
273 handler procedure written in Scheme. HANDLER_DATA is a pointer to
274 an SCM variable holding the Scheme procedure object to invoke. It
275 ought to be a pointer to an automatic variable (i.e., one living on
276 the stack), or the procedure object should be otherwise protected
279 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
281 SCM
*handler_proc_p
= (SCM
*) handler_data
;
283 return scm_apply_1 (*handler_proc_p
, tag
, throw_args
);
286 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
287 catches all throws that the handler might emit itself. The handler
288 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
296 hbpca_body (void *body_data
)
298 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
299 return scm_apply_0 (data
->proc
, data
->args
);
303 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
305 SCM
*handler_proc_p
= (SCM
*) handler_data
;
306 struct hbpca_data data
;
307 data
.proc
= *handler_proc_p
;
308 data
.args
= scm_cons (tag
, throw_args
);
310 return scm_internal_catch (SCM_BOOL_T
,
312 scm_handle_by_message_noexit
, NULL
);
315 /* Derive the an exit status from the arguments to (quit ...). */
317 scm_exit_status (SCM args
)
319 if (!SCM_NULL_OR_NIL_P (args
))
321 SCM cqa
= SCM_CAR (args
);
323 if (scm_is_integer (cqa
))
324 return (scm_to_int (cqa
));
325 else if (scm_is_false (cqa
))
333 should_print_backtrace (SCM tag
, SCM stack
)
335 return SCM_BACKTRACE_P
336 && scm_is_true (stack
)
338 /* It's generally not useful to print backtraces for errors reading
339 or expanding code in these fallback catch statements. */
340 && !scm_is_eq (tag
, scm_from_latin1_symbol ("read-error"))
341 && !scm_is_eq (tag
, scm_from_latin1_symbol ("syntax-error"));
345 handler_message (void *handler_data
, SCM tag
, SCM args
)
349 p
= scm_current_error_port ();
350 /* Usually we get here via a throw to a catch-all. In that case
351 there is the throw frame active, and the catch closure, so narrow by
352 two frames. It is possible for a user to invoke
353 scm_handle_by_message directly, though, so it could be this
354 narrows too much. We'll have to see how this works out in
356 stack
= scm_make_stack (SCM_BOOL_T
, scm_list_1 (scm_from_int (2)));
357 frame
= scm_is_true (stack
) ? scm_stack_ref (stack
, SCM_INUM0
) : SCM_BOOL_F
;
359 if (should_print_backtrace (tag
, stack
))
361 scm_puts ("Backtrace:\n", p
);
362 scm_display_backtrace_with_highlights (stack
, p
,
363 SCM_BOOL_F
, SCM_BOOL_F
,
368 scm_print_exception (p
, frame
, tag
, args
);
372 /* This is a handler function to use if you want scheme to print a
373 message and die. Useful for dealing with throws to uncaught keys
376 At boot time, we establish a catch-all that uses this as its handler.
377 1) If the user wants something different, they can use (catch #t
378 ...) to do what they like.
379 2) Outside the context of a read-eval-print loop, there isn't
380 anything else good to do; libguile should not assume the existence
381 of a read-eval-print loop.
382 3) Given that we shouldn't do anything complex, it's much more
383 robust to do it in C code.
385 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
386 message header to print; if zero, we use "guile" instead. That
387 text is followed by a colon, then the message described by ARGS. */
389 /* Dirk:FIXME:: The name of the function should make clear that the
390 * application gets terminated.
394 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
396 if (scm_is_true (scm_eq_p (tag
, scm_from_latin1_symbol ("quit"))))
397 exit (scm_exit_status (args
));
399 handler_message (handler_data
, tag
, args
);
400 scm_i_pthread_exit (NULL
);
402 /* this point not reached, but suppress gcc warning about no return value
403 in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
404 to be the case on cygwin for instance) */
409 /* This is just like scm_handle_by_message, but it doesn't exit; it
410 just returns #f. It's useful in cases where you don't really know
411 enough about the body to handle things in a better way, but don't
412 want to let throws fall off the bottom of the wind list. */
414 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
416 if (scm_is_true (scm_eq_p (tag
, scm_from_latin1_symbol ("quit"))))
417 exit (scm_exit_status (args
));
419 handler_message (handler_data
, tag
, args
);
426 scm_handle_by_throw (void *handler_data SCM_UNUSED
, SCM tag
, SCM args
)
428 scm_ithrow (tag
, args
, 1);
429 return SCM_UNSPECIFIED
; /* never returns */
433 scm_ithrow (SCM key
, SCM args
, int no_return SCM_UNUSED
)
435 return scm_throw (key
, args
);
438 /* Unfortunately we have to support catch and throw before boot-9 has, um,
439 booted. So here are lame versions, which will get replaced with their scheme
442 SCM_SYMBOL (sym_pre_init_catch_tag
, "%pre-init-catch-tag");
445 pre_init_catch (SCM tag
, SCM thunk
, SCM handler
, SCM pre_unwind_handler
)
449 /* Only handle catch-alls without pre-unwind handlers */
450 if (!SCM_UNBNDP (pre_unwind_handler
))
452 if (scm_is_false (scm_eqv_p (tag
, SCM_BOOL_T
)))
456 prompt
= scm_c_make_prompt (sym_pre_init_catch_tag
,
457 SCM_VM_DATA (vm
)->fp
, SCM_VM_DATA (vm
)->sp
,
458 SCM_VM_DATA (vm
)->ip
, 1, -1, scm_i_dynwinds ());
459 scm_i_set_dynwinds (scm_cons (prompt
, SCM_PROMPT_DYNWINDS (prompt
)));
461 if (SCM_PROMPT_SETJMP (prompt
))
464 SCM args
= scm_i_prompt_pop_abort_args_x (vm
);
465 /* cdr past the continuation */
466 return scm_apply_0 (handler
, scm_cdr (args
));
469 res
= scm_call_0 (thunk
);
470 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
476 find_pre_init_catch (void)
480 /* Search the wind list for an appropriate prompt.
481 "Waiter, please bring us the wind list." */
482 for (winds
= scm_i_dynwinds (); scm_is_pair (winds
); winds
= SCM_CDR (winds
))
483 if (SCM_PROMPT_P (SCM_CAR (winds
))
484 && scm_is_eq (SCM_PROMPT_TAG (SCM_CAR (winds
)), sym_pre_init_catch_tag
))
491 pre_init_throw (SCM k
, SCM args
)
493 if (find_pre_init_catch ())
494 return scm_at_abort (sym_pre_init_catch_tag
, scm_cons (k
, args
));
497 static int error_printing_error
= 0;
498 static int error_printing_fallback
= 0;
500 if (error_printing_fallback
)
501 fprintf (stderr
, "\nFailed to print exception.\n");
502 else if (error_printing_error
)
504 fprintf (stderr
, "\nError while printing exception:\n");
505 error_printing_fallback
= 1;
506 fprintf (stderr
, "Key: ");
507 scm_write (k
, scm_current_error_port ());
508 fprintf (stderr
, ", args: ");
509 scm_write (args
, scm_current_error_port ());
510 scm_newline (scm_current_error_port ());
514 fprintf (stderr
, "Throw without catch before boot:\n");
515 error_printing_error
= 1;
516 scm_handle_by_message_noexit (NULL
, k
, args
);
519 fprintf (stderr
, "Aborting.\n");
521 return SCM_BOOL_F
; /* not reached */
528 tc16_catch_closure
= scm_make_smob_type ("catch-closure", 0);
529 scm_set_smob_apply (tc16_catch_closure
, apply_catch_closure
, 0, 0, 1);
531 catch_var
= scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0,
533 throw_var
= scm_c_define ("throw", scm_c_make_gsubr ("throw", 1, 0, 1,
536 #include "libguile/throw.x"