remove libguile/lang.h, deprecate %nil (in favor of #nil)
[bpt/guile.git] / libguile / throw.c
CommitLineData
416f26c7 1/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
0f2d19dd 2 *
73be1d9e 3 * This library is free software; you can redistribute it and/or
53befeb7
NJ
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.
0f2d19dd 7 *
53befeb7
NJ
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e
MV
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
0f2d19dd 12 *
73be1d9e
MV
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
53befeb7
NJ
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
16 * 02110-1301 USA
73be1d9e 17 */
1bbd0b84 18
1bbd0b84 19
0f2d19dd 20\f
dbb605f5
LC
21#ifdef HAVE_CONFIG_H
22# include <config.h>
23#endif
0f2d19dd
JB
24
25#include <stdio.h>
27646f41 26#include <unistdio.h>
a0599745
MD
27#include "libguile/_scm.h"
28#include "libguile/smob.h"
a0599745
MD
29#include "libguile/eval.h"
30#include "libguile/eq.h"
416f26c7 31#include "libguile/control.h"
e10cf6b9 32#include "libguile/deprecation.h"
a0599745 33#include "libguile/backtrace.h"
a0599745 34#include "libguile/debug.h"
a0599745
MD
35#include "libguile/stackchk.h"
36#include "libguile/stacks.h"
37#include "libguile/fluids.h"
38#include "libguile/ports.h"
a0599745 39#include "libguile/validate.h"
416f26c7 40#include "libguile/vm.h"
a0599745 41#include "libguile/throw.h"
9de87eea 42#include "libguile/init.h"
a2c40dc7 43#include "libguile/strings.h"
0f2d19dd 44
22fc179a
HWN
45#include "libguile/private-options.h"
46
47
416f26c7
AW
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.
0f2d19dd 51
416f26c7
AW
52 All of these function names and prototypes carry a fair bit of historical
53 baggage. */
c209c88e 54
0f2d19dd 55
416f26c7
AW
56#define CACHE_VAR(var,name) \
57 static SCM var = SCM_BOOL_F; \
58 if (scm_is_false (var)) \
59 { \
60 var = scm_module_variable (scm_the_root_module (), \
61 scm_from_locale_symbol (name)); \
62 if (scm_is_false (var)) \
63 abort (); \
64 }
0f2d19dd 65
416f26c7
AW
66\f
67
68SCM
69scm_catch (SCM key, SCM thunk, SCM handler)
0f2d19dd 70{
416f26c7
AW
71 CACHE_VAR (var, "catch");
72
73 return scm_call_3 (scm_variable_ref (var), key, thunk, handler);
0f2d19dd
JB
74}
75
416f26c7
AW
76SCM
77scm_catch_with_pre_unwind_handler (SCM key, SCM thunk, SCM handler,
78 SCM pre_unwind_handler)
0f2d19dd 79{
416f26c7
AW
80 if (SCM_UNBNDP (pre_unwind_handler))
81 return scm_catch (key, thunk, handler);
82 else
83 {
84 CACHE_VAR (var, "catch");
85
86 return scm_call_4 (scm_variable_ref (var), key, thunk, handler,
87 pre_unwind_handler);
88 }
0f2d19dd
JB
89}
90
416f26c7
AW
91SCM
92scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
93{
94 CACHE_VAR (var, "with-throw-handler");
95
96 return scm_call_3 (scm_variable_ref (var), key, thunk, handler);
97}
74229f75 98
416f26c7
AW
99SCM
100scm_throw (SCM key, SCM args)
0f2d19dd 101{
416f26c7
AW
102 CACHE_VAR (var, "throw");
103
104 return scm_apply_1 (scm_variable_ref (var), key, args);
105}
106
107\f
0f2d19dd 108
416f26c7 109/* Now some support for C bodies and catch handlers */
650fa1ab 110
416f26c7 111static scm_t_bits tc16_catch_closure;
43e01b1e 112
416f26c7
AW
113enum {
114 CATCH_CLOSURE_BODY,
115 CATCH_CLOSURE_HANDLER
43e01b1e
NJ
116};
117
416f26c7
AW
118static SCM
119make_catch_body_closure (scm_t_catch_body body, void *body_data)
120{
121 SCM ret;
122 SCM_NEWSMOB2 (ret, tc16_catch_closure, body, body_data);
123 SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_BODY);
124 return ret;
125}
126
127static SCM
128make_catch_handler_closure (scm_t_catch_handler handler, void *handler_data)
129{
130 SCM ret;
131 SCM_NEWSMOB2 (ret, tc16_catch_closure, handler, handler_data);
132 SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_HANDLER);
133 return ret;
134}
43e01b1e 135
416f26c7
AW
136static SCM
137apply_catch_closure (SCM clo, SCM args)
138{
139 void *data = (void*)SCM_SMOB_DATA_2 (clo);
650fa1ab 140
416f26c7
AW
141 switch (SCM_SMOB_FLAGS (clo))
142 {
143 case CATCH_CLOSURE_BODY:
144 {
145 scm_t_catch_body body = (void*)SCM_SMOB_DATA (clo);
146 return body (data);
147 }
148 case CATCH_CLOSURE_HANDLER:
149 {
150 scm_t_catch_handler handler = (void*)SCM_SMOB_DATA (clo);
151 return handler (data, scm_car (args), scm_cdr (args));
152 }
153 default:
154 abort ();
155 }
156}
650fa1ab 157
416f26c7 158/* TAG is the catch tag. Typically, this is a symbol, but this
650fa1ab
JB
159 function doesn't actually care about that.
160
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:
19b27fa2 163 BODY (BODY_DATA)
650fa1ab 164 where:
816a6f06
JB
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.
650fa1ab
JB
168
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:
86327304 171 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
650fa1ab 172 where
816a6f06
JB
173 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
174 same idea as BODY_DATA above.
86327304
JB
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.
650fa1ab 178 THROW_ARGS is the list of arguments the user passed to the THROW
4dd8323f 179 function, after the tag.
650fa1ab 180
3eed3475
JB
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
188 enclosed variables.
189
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
195 will be found. */
650fa1ab 196
0f2d19dd 197SCM
43e01b1e
NJ
198scm_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)
0f2d19dd 202{
416f26c7
AW
203 SCM sbody, shandler, spre_unwind_handler;
204
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);
0f2d19dd 210 else
416f26c7
AW
211 spre_unwind_handler = SCM_UNDEFINED;
212
213 return scm_catch_with_pre_unwind_handler (tag, sbody, shandler,
214 spre_unwind_handler);
0f2d19dd
JB
215}
216
43e01b1e
NJ
217SCM
218scm_internal_catch (SCM tag,
219 scm_t_catch_body body, void *body_data,
220 scm_t_catch_handler handler, void *handler_data)
221{
416f26c7
AW
222 return scm_c_catch (tag,
223 body, body_data,
224 handler, handler_data,
225 NULL, NULL);
18eadcbe
JB
226}
227
18eadcbe 228
18eadcbe 229SCM
43e01b1e
NJ
230scm_c_with_throw_handler (SCM tag,
231 scm_t_catch_body body,
232 void *body_data,
233 scm_t_catch_handler handler,
234 void *handler_data,
235 int lazy_catch_p)
18eadcbe 236{
416f26c7 237 SCM sbody, shandler;
18eadcbe 238
e10cf6b9
AW
239 if (lazy_catch_p)
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"
247 "of the throw.");
248
416f26c7
AW
249 sbody = make_catch_body_closure (body, body_data);
250 shandler = make_catch_handler_closure (handler, handler_data);
251
252 return scm_with_throw_handler (tag, sbody, shandler);
18eadcbe
JB
253}
254
95384717
MD
255\f
256/* scm_internal_stack_catch
257 Use this one if you want debugging information to be stored in
86d31dfe 258 scm_the_last_stack_fluid_var on error. */
95384717
MD
259
260static SCM
e81d98ec 261ss_handler (void *data SCM_UNUSED, SCM tag, SCM throw_args)
95384717
MD
262{
263 /* Save the stack */
86d31dfe 264 scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var),
af45e3b0 265 scm_make_stack (SCM_BOOL_T, SCM_EOL));
95384717
MD
266 /* Throw the error */
267 return scm_throw (tag, throw_args);
268}
269
270struct cwss_data
271{
272 SCM tag;
92c2555f 273 scm_t_catch_body body;
95384717
MD
274 void *data;
275};
276
277static SCM
492960a4 278cwss_body (void *data)
95384717
MD
279{
280 struct cwss_data *d = data;
e10cf6b9 281 return scm_c_with_throw_handler (d->tag, d->body, d->data, ss_handler, NULL, 0);
95384717
MD
282}
283
284SCM
285scm_internal_stack_catch (SCM tag,
92c2555f 286 scm_t_catch_body body,
95384717 287 void *body_data,
92c2555f 288 scm_t_catch_handler handler,
95384717
MD
289 void *handler_data)
290{
291 struct cwss_data d;
292 d.tag = tag;
293 d.body = body;
294 d.data = body_data;
295 return scm_internal_catch (tag, cwss_body, &d, handler, handler_data);
296}
297
18eadcbe
JB
298
299\f
95384717 300/* body and handler functions for use with any of the above catch variants */
18eadcbe 301
816a6f06 302/* This is a body function you can pass to scm_internal_catch if you
492960a4 303 want the body to be like Scheme's `catch' --- a thunk.
650fa1ab 304
74229f75
JB
305 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
306 contains the Scheme procedure to invoke as the body, and the tag
492960a4 307 we're catching. */
650fa1ab 308
816a6f06 309SCM
6e8d25a6 310scm_body_thunk (void *body_data)
650fa1ab 311{
816a6f06 312 struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data;
650fa1ab 313
fdc28395 314 return scm_call_0 (c->body_proc);
650fa1ab
JB
315}
316
317
74229f75 318/* This is a handler function you can pass to scm_internal_catch if
4dd8323f
JB
319 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
320 applies a handler procedure to (TAG ARGS ...).
74229f75
JB
321
322 If the user does a throw to this catch, this function runs a
816a6f06
JB
323 handler procedure written in Scheme. HANDLER_DATA is a pointer to
324 an SCM variable holding the Scheme procedure object to invoke. It
74229f75
JB
325 ought to be a pointer to an automatic variable (i.e., one living on
326 the stack), or the procedure object should be otherwise protected
327 from GC. */
816a6f06 328SCM
6e8d25a6 329scm_handle_by_proc (void *handler_data, SCM tag, SCM throw_args)
650fa1ab 330{
816a6f06 331 SCM *handler_proc_p = (SCM *) handler_data;
650fa1ab 332
fdc28395 333 return scm_apply_1 (*handler_proc_p, tag, throw_args);
650fa1ab
JB
334}
335
1345df5d
MV
336/* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
337 catches all throws that the handler might emit itself. The handler
338 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
339
340struct hbpca_data {
341 SCM proc;
342 SCM args;
343};
344
345static SCM
6e8d25a6 346hbpca_body (void *body_data)
1345df5d
MV
347{
348 struct hbpca_data *data = (struct hbpca_data *)body_data;
fdc28395 349 return scm_apply_0 (data->proc, data->args);
1345df5d
MV
350}
351
352SCM
6e8d25a6 353scm_handle_by_proc_catching_all (void *handler_data, SCM tag, SCM throw_args)
1345df5d
MV
354{
355 SCM *handler_proc_p = (SCM *) handler_data;
356 struct hbpca_data data;
357 data.proc = *handler_proc_p;
358 data.args = scm_cons (tag, throw_args);
359
360 return scm_internal_catch (SCM_BOOL_T,
361 hbpca_body, &data,
362 scm_handle_by_message_noexit, NULL);
363}
650fa1ab 364
f032b8a8
JB
365/* Derive the an exit status from the arguments to (quit ...). */
366int
6e8d25a6 367scm_exit_status (SCM args)
f032b8a8 368{
c96d76b8 369 if (!SCM_NULL_OR_NIL_P (args))
f032b8a8
JB
370 {
371 SCM cqa = SCM_CAR (args);
372
e11e83f3
MV
373 if (scm_is_integer (cqa))
374 return (scm_to_int (cqa));
7888309b 375 else if (scm_is_false (cqa))
f032b8a8
JB
376 return 1;
377 }
378 return 0;
379}
380
74229f75 381
f032b8a8
JB
382static void
383handler_message (void *handler_data, SCM tag, SCM args)
e68b42c1 384{
74229f75 385 char *prog_name = (char *) handler_data;
9de87eea 386 SCM p = scm_current_error_port ();
650fa1ab 387
aa79839a 388 if (scm_ilength (args) == 4)
74229f75 389 {
af45e3b0 390 SCM stack = scm_make_stack (SCM_BOOL_T, SCM_EOL);
f64056d1 391 SCM subr = SCM_CAR (args);
74229f75 392 SCM message = SCM_CADR (args);
f64056d1 393 SCM parts = SCM_CADDR (args);
aa79839a 394 SCM rest = SCM_CADDDR (args);
74229f75 395
7888309b 396 if (SCM_BACKTRACE_P && scm_is_true (stack))
85691806 397 {
aa79839a
MV
398 SCM highlights;
399
400 if (scm_is_eq (tag, scm_arg_type_key)
401 || scm_is_eq (tag, scm_out_of_range_key))
402 highlights = rest;
403 else
404 highlights = SCM_EOL;
405
85691806 406 scm_puts ("Backtrace:\n", p);
aa79839a
MV
407 scm_display_backtrace_with_highlights (stack, p,
408 SCM_BOOL_F, SCM_BOOL_F,
409 highlights);
85691806
MD
410 scm_newline (p);
411 }
e40a4095 412 scm_i_display_error (stack, p, subr, message, parts, rest);
74229f75
JB
413 }
414 else
415 {
f64056d1
JB
416 if (! prog_name)
417 prog_name = "guile";
418
419 scm_puts (prog_name, p);
420 scm_puts (": ", p);
421
b7f3516f 422 scm_puts ("uncaught throw to ", p);
74229f75 423 scm_prin1 (tag, p, 0);
b7f3516f 424 scm_puts (": ", p);
74229f75 425 scm_prin1 (args, p, 1);
b7f3516f 426 scm_putc ('\n', p);
74229f75 427 }
f032b8a8
JB
428}
429
430
431/* This is a handler function to use if you want scheme to print a
432 message and die. Useful for dealing with throws to uncaught keys
433 at the top level.
434
435 At boot time, we establish a catch-all that uses this as its handler.
436 1) If the user wants something different, they can use (catch #t
437 ...) to do what they like.
438 2) Outside the context of a read-eval-print loop, there isn't
439 anything else good to do; libguile should not assume the existence
440 of a read-eval-print loop.
441 3) Given that we shouldn't do anything complex, it's much more
442 robust to do it in C code.
443
444 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
445 message header to print; if zero, we use "guile" instead. That
446 text is followed by a colon, then the message described by ARGS. */
447
5a2a5407
DH
448/* Dirk:FIXME:: The name of the function should make clear that the
449 * application gets terminated.
450 */
451
f032b8a8 452SCM
6e8d25a6 453scm_handle_by_message (void *handler_data, SCM tag, SCM args)
f032b8a8 454{
cc95e00a 455 if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
9de87eea 456 exit (scm_exit_status (args));
f032b8a8
JB
457
458 handler_message (handler_data, tag, args);
9de87eea 459 scm_i_pthread_exit (NULL);
23f2b9a3
KR
460
461 /* this point not reached, but suppress gcc warning about no return value
462 in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
463 to be the case on cygwin for instance) */
464 return SCM_BOOL_F;
74229f75
JB
465}
466
467
f032b8a8
JB
468/* This is just like scm_handle_by_message, but it doesn't exit; it
469 just returns #f. It's useful in cases where you don't really know
470 enough about the body to handle things in a better way, but don't
471 want to let throws fall off the bottom of the wind list. */
472SCM
6e8d25a6 473scm_handle_by_message_noexit (void *handler_data, SCM tag, SCM args)
74229f75 474{
9de87eea
MV
475 if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
476 exit (scm_exit_status (args));
477
f032b8a8
JB
478 handler_message (handler_data, tag, args);
479
480 return SCM_BOOL_F;
e68b42c1
MD
481}
482
3eed3475 483
e158e4f4 484SCM
e81d98ec 485scm_handle_by_throw (void *handler_data SCM_UNUSED, SCM tag, SCM args)
e158e4f4
MD
486{
487 scm_ithrow (tag, args, 1);
488 return SCM_UNSPECIFIED; /* never returns */
489}
490
43e01b1e 491SCM
416f26c7 492scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
ad310508 493{
416f26c7 494 return scm_throw (key, args);
ad310508
MD
495}
496
416f26c7
AW
497/* Unfortunately we have to support catch and throw before boot-9 has, um,
498 booted. So here are lame versions, which will get replaced with their scheme
499 equivalents. */
c6a32a2c
AW
500
501SCM_SYMBOL (sym_pre_init_catch_tag, "%pre-init-catch-tag");
502
416f26c7
AW
503static SCM
504pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
0f2d19dd 505{
416f26c7 506 SCM vm, prompt, res;
492960a4 507
416f26c7
AW
508 /* Only handle catch-alls without pre-unwind handlers */
509 if (!SCM_UNBNDP (pre_unwind_handler))
510 abort ();
511 if (scm_is_false (scm_eqv_p (tag, SCM_BOOL_T)))
d6580119 512 abort ();
43e01b1e 513
416f26c7 514 vm = scm_the_vm ();
c6a32a2c 515 prompt = scm_c_make_prompt (sym_pre_init_catch_tag,
416f26c7 516 SCM_VM_DATA (vm)->fp, SCM_VM_DATA (vm)->sp,
adbdfd6d
AW
517 SCM_VM_DATA (vm)->ip, 1, -1, scm_i_dynwinds ());
518 scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
43e01b1e 519
416f26c7
AW
520 if (SCM_PROMPT_SETJMP (prompt))
521 {
522 /* nonlocal exit */
523 SCM args = scm_i_prompt_pop_abort_args_x (prompt);
524 /* cdr past the continuation */
525 return scm_apply_0 (handler, scm_cdr (args));
11702758 526 }
3eed3475 527
416f26c7
AW
528 res = scm_call_0 (thunk);
529 scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
346e4402 530
416f26c7 531 return res;
0f2d19dd
JB
532}
533
416f26c7
AW
534static SCM
535pre_init_throw (SCM args)
536{
c6a32a2c 537 return scm_at_abort (sym_pre_init_catch_tag, args);
416f26c7 538}
0f2d19dd 539
0f2d19dd
JB
540void
541scm_init_throw ()
0f2d19dd 542{
416f26c7
AW
543 tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
544 scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);
e841c3e0 545
416f26c7
AW
546 scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0, pre_init_catch));
547 scm_c_define ("throw", scm_c_make_gsubr ("throw", 0, 0, 1, pre_init_throw));
e841c3e0 548
a0599745 549#include "libguile/throw.x"
0f2d19dd 550}
89e00824
ML
551
552/*
553 Local Variables:
554 c-file-style: "gnu"
555 End:
556*/