* Replaced a lot of calls to SCM_C[AD]R with more appropriate macros.
[bpt/guile.git] / libguile / throw.c
1 /* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc.
2 *
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
6 * any later version.
7 *
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
17 *
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
20 *
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
26 *
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
29 *
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
37 *
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
41
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
44
45 \f
46
47 #include <stdio.h>
48 #include "libguile/_scm.h"
49 #include "libguile/smob.h"
50 #include "libguile/alist.h"
51 #include "libguile/eval.h"
52 #include "libguile/eq.h"
53 #include "libguile/dynwind.h"
54 #include "libguile/backtrace.h"
55 #ifdef DEBUG_EXTENSIONS
56 #include "libguile/debug.h"
57 #endif
58 #include "libguile/continuations.h"
59 #include "libguile/stackchk.h"
60 #include "libguile/stacks.h"
61 #include "libguile/fluids.h"
62 #include "libguile/ports.h"
63
64 #include "libguile/validate.h"
65 #include "libguile/throw.h"
66
67 \f
68 /* the jump buffer data structure */
69 static scm_bits_t tc16_jmpbuffer;
70
71 #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
72
73 #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
74 #define ACTIVATEJB(x) \
75 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
76 #define DEACTIVATEJB(x) \
77 (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))
78
79 #define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
80 #define SETJBJMPBUF(x,v) (SCM_SET_CELL_WORD_1 ((x), (v)))
81 #ifdef DEBUG_EXTENSIONS
82 #define SCM_JBDFRAME(x) ((scm_debug_frame *) SCM_CELL_WORD_2 (x))
83 #define SCM_SETJBDFRAME(x,v) (SCM_SET_CELL_WORD_2 ((x), (v)))
84 #endif
85
86 static int
87 jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate)
88 {
89 scm_puts ("#<jmpbuffer ", port);
90 scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
91 scm_intprint((long) JBJMPBUF (exp), 16, port);
92 scm_putc ('>', port);
93 return 1 ;
94 }
95
96 static SCM
97 make_jmpbuf (void)
98 {
99 SCM answer;
100 SCM_REDEFER_INTS;
101 {
102 #ifdef DEBUG_EXTENSIONS
103 SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
104 #else
105 SCM_NEWSMOB (answer, tc16_jmpbuffer, 0);
106 #endif
107 SETJBJMPBUF(answer, (jmp_buf *)0);
108 DEACTIVATEJB(answer);
109 }
110 SCM_REALLOW_INTS;
111 return answer;
112 }
113
114 \f
115 /* scm_internal_catch (the guts of catch) */
116
117 struct jmp_buf_and_retval /* use only on the stack, in scm_catch */
118 {
119 jmp_buf buf; /* must be first */
120 SCM throw_tag;
121 SCM retval;
122 };
123
124
125 /* scm_internal_catch is the guts of catch. It handles all the
126 mechanics of setting up a catch target, invoking the catch body,
127 and perhaps invoking the handler if the body does a throw.
128
129 The function is designed to be usable from C code, but is general
130 enough to implement all the semantics Guile Scheme expects from
131 throw.
132
133 TAG is the catch tag. Typically, this is a symbol, but this
134 function doesn't actually care about that.
135
136 BODY is a pointer to a C function which runs the body of the catch;
137 this is the code you can throw from. We call it like this:
138 BODY (BODY_DATA)
139 where:
140 BODY_DATA is just the BODY_DATA argument we received; we pass it
141 through to BODY as its first argument. The caller can make
142 BODY_DATA point to anything useful that BODY might need.
143
144 HANDLER is a pointer to a C function to deal with a throw to TAG,
145 should one occur. We call it like this:
146 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
147 where
148 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
149 same idea as BODY_DATA above.
150 THROWN_TAG is the tag that the user threw to; usually this is
151 TAG, but it could be something else if TAG was #t (i.e., a
152 catch-all), or the user threw to a jmpbuf.
153 THROW_ARGS is the list of arguments the user passed to the THROW
154 function, after the tag.
155
156 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
157 is just a pointer we pass through to HANDLER. We don't actually
158 use either of those pointers otherwise ourselves. The idea is
159 that, if our caller wants to communicate something to BODY or
160 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
161 HANDLER can then use. Think of it as a way to make BODY and
162 HANDLER closures, not just functions; MUMBLE_DATA points to the
163 enclosed variables.
164
165 Of course, it's up to the caller to make sure that any data a
166 MUMBLE_DATA needs is protected from GC. A common way to do this is
167 to make MUMBLE_DATA a pointer to data stored in an automatic
168 structure variable; since the collector must scan the stack for
169 references anyway, this assures that any references in MUMBLE_DATA
170 will be found. */
171
172 SCM
173 scm_internal_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data)
174 {
175 struct jmp_buf_and_retval jbr;
176 SCM jmpbuf;
177 SCM answer;
178
179 jmpbuf = make_jmpbuf ();
180 answer = SCM_EOL;
181 scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds);
182 SETJBJMPBUF(jmpbuf, &jbr.buf);
183 #ifdef DEBUG_EXTENSIONS
184 SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame);
185 #endif
186 if (setjmp (jbr.buf))
187 {
188 SCM throw_tag;
189 SCM throw_args;
190
191 #ifdef STACK_CHECKING
192 scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
193 #endif
194 SCM_REDEFER_INTS;
195 DEACTIVATEJB (jmpbuf);
196 scm_dynwinds = SCM_CDR (scm_dynwinds);
197 SCM_REALLOW_INTS;
198 throw_args = jbr.retval;
199 throw_tag = jbr.throw_tag;
200 jbr.throw_tag = SCM_EOL;
201 jbr.retval = SCM_EOL;
202 answer = handler (handler_data, throw_tag, throw_args);
203 }
204 else
205 {
206 ACTIVATEJB (jmpbuf);
207 answer = body (body_data);
208 SCM_REDEFER_INTS;
209 DEACTIVATEJB (jmpbuf);
210 scm_dynwinds = SCM_CDR (scm_dynwinds);
211 SCM_REALLOW_INTS;
212 }
213 return answer;
214 }
215
216
217 \f
218 /* scm_internal_lazy_catch (the guts of lazy catching) */
219
220 /* The smob tag for lazy_catch smobs. */
221 static scm_bits_t tc16_lazy_catch;
222
223 /* This is the structure we put on the wind list for a lazy catch. It
224 stores the handler function to call, and the data pointer to pass
225 through to it. It's not a Scheme closure, but it is a function
226 with data, so the term "closure" is appropriate in its broader
227 sense.
228
229 (We don't need anything like this in the "eager" catch code,
230 because the same C frame runs both the body and the handler.) */
231 struct lazy_catch {
232 scm_catch_handler_t handler;
233 void *handler_data;
234 };
235
236 /* Strictly speaking, we could just pass a zero for our print
237 function, because we don't need to print them. They should never
238 appear in normal data structures, only in the wind list. However,
239 it might be nice for debugging someday... */
240 static int
241 lazy_catch_print (SCM closure, SCM port, scm_print_state *pstate)
242 {
243 struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (closure);
244 char buf[200];
245
246 sprintf (buf, "#<lazy-catch 0x%lx 0x%lx>",
247 (long) c->handler, (long) c->handler_data);
248 scm_puts (buf, port);
249
250 return 1;
251 }
252
253
254 /* Given a pointer to a lazy catch structure, return a smob for it,
255 suitable for inclusion in the wind list. ("Ah yes, a Château
256 Gollombiere '72, non?"). */
257 static SCM
258 make_lazy_catch (struct lazy_catch *c)
259 {
260 SCM_RETURN_NEWSMOB (tc16_lazy_catch, c);
261 }
262
263 #define SCM_LAZY_CATCH_P(obj) (SCM_TYP16_PREDICATE (tc16_lazy_catch, obj))
264
265
266 /* Exactly like scm_internal_catch, except:
267 - It does not unwind the stack (this is the major difference).
268 - If handler returns, its value is returned from the throw. */
269 SCM
270 scm_internal_lazy_catch (SCM tag, scm_catch_body_t body, void *body_data, scm_catch_handler_t handler, void *handler_data)
271 {
272 SCM lazy_catch, answer;
273 struct lazy_catch c;
274
275 c.handler = handler;
276 c.handler_data = handler_data;
277 lazy_catch = make_lazy_catch (&c);
278
279 SCM_REDEFER_INTS;
280 scm_dynwinds = scm_acons (tag, lazy_catch, scm_dynwinds);
281 SCM_REALLOW_INTS;
282
283 answer = (*body) (body_data);
284
285 SCM_REDEFER_INTS;
286 scm_dynwinds = SCM_CDR (scm_dynwinds);
287 SCM_REALLOW_INTS;
288
289 return answer;
290 }
291
292 \f
293 /* scm_internal_stack_catch
294 Use this one if you want debugging information to be stored in
295 scm_the_last_stack_fluid on error. */
296
297 static SCM
298 ss_handler (void *data, SCM tag, SCM throw_args)
299 {
300 /* Save the stack */
301 scm_fluid_set_x (SCM_CDR (scm_the_last_stack_fluid),
302 scm_make_stack (SCM_BOOL_T, SCM_EOL));
303 /* Throw the error */
304 return scm_throw (tag, throw_args);
305 }
306
307 struct cwss_data
308 {
309 SCM tag;
310 scm_catch_body_t body;
311 void *data;
312 };
313
314 static SCM
315 cwss_body (void *data)
316 {
317 struct cwss_data *d = data;
318 return scm_internal_lazy_catch (d->tag, d->body, d->data, ss_handler, NULL);
319 }
320
321 SCM
322 scm_internal_stack_catch (SCM tag,
323 scm_catch_body_t body,
324 void *body_data,
325 scm_catch_handler_t handler,
326 void *handler_data)
327 {
328 struct cwss_data d;
329 d.tag = tag;
330 d.body = body;
331 d.data = body_data;
332 return scm_internal_catch (tag, cwss_body, &d, handler, handler_data);
333 }
334
335
336 \f
337 /* body and handler functions for use with any of the above catch variants */
338
339 /* This is a body function you can pass to scm_internal_catch if you
340 want the body to be like Scheme's `catch' --- a thunk.
341
342 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
343 contains the Scheme procedure to invoke as the body, and the tag
344 we're catching. */
345
346 SCM
347 scm_body_thunk (void *body_data)
348 {
349 struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data;
350
351 return scm_apply (c->body_proc, SCM_EOL, SCM_EOL);
352 }
353
354
355 /* This is a handler function you can pass to scm_internal_catch if
356 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
357 applies a handler procedure to (TAG ARGS ...).
358
359 If the user does a throw to this catch, this function runs a
360 handler procedure written in Scheme. HANDLER_DATA is a pointer to
361 an SCM variable holding the Scheme procedure object to invoke. It
362 ought to be a pointer to an automatic variable (i.e., one living on
363 the stack), or the procedure object should be otherwise protected
364 from GC. */
365 SCM
366 scm_handle_by_proc (void *handler_data, SCM tag, SCM throw_args)
367 {
368 SCM *handler_proc_p = (SCM *) handler_data;
369
370 return scm_apply (*handler_proc_p, scm_cons (tag, throw_args), SCM_EOL);
371 }
372
373 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
374 catches all throws that the handler might emit itself. The handler
375 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
376
377 struct hbpca_data {
378 SCM proc;
379 SCM args;
380 };
381
382 static SCM
383 hbpca_body (void *body_data)
384 {
385 struct hbpca_data *data = (struct hbpca_data *)body_data;
386 return scm_apply (data->proc, data->args, SCM_EOL);
387 }
388
389 SCM
390 scm_handle_by_proc_catching_all (void *handler_data, SCM tag, SCM throw_args)
391 {
392 SCM *handler_proc_p = (SCM *) handler_data;
393 struct hbpca_data data;
394 data.proc = *handler_proc_p;
395 data.args = scm_cons (tag, throw_args);
396
397 return scm_internal_catch (SCM_BOOL_T,
398 hbpca_body, &data,
399 scm_handle_by_message_noexit, NULL);
400 }
401
402 /* Derive the an exit status from the arguments to (quit ...). */
403 int
404 scm_exit_status (SCM args)
405 {
406 if (SCM_NNULLP (args))
407 {
408 SCM cqa = SCM_CAR (args);
409
410 if (SCM_INUMP (cqa))
411 return (SCM_INUM (cqa));
412 else if (SCM_FALSEP (cqa))
413 return 1;
414 }
415 return 0;
416 }
417
418
419 static void
420 handler_message (void *handler_data, SCM tag, SCM args)
421 {
422 char *prog_name = (char *) handler_data;
423 SCM p = scm_cur_errp;
424
425 if (scm_ilength (args) >= 3)
426 {
427 SCM stack = scm_make_stack (SCM_BOOL_T, SCM_EOL);
428 SCM subr = SCM_CAR (args);
429 SCM message = SCM_CADR (args);
430 SCM parts = SCM_CADDR (args);
431 SCM rest = SCM_CDDDR (args);
432
433 if (SCM_BACKTRACE_P && SCM_NFALSEP (stack))
434 {
435 scm_puts ("Backtrace:\n", p);
436 scm_display_backtrace (stack, p, SCM_UNDEFINED, SCM_UNDEFINED);
437 scm_newline (p);
438 }
439 scm_i_display_error (stack, p, subr, message, parts, rest);
440 }
441 else
442 {
443 if (! prog_name)
444 prog_name = "guile";
445
446 scm_puts (prog_name, p);
447 scm_puts (": ", p);
448
449 scm_puts ("uncaught throw to ", p);
450 scm_prin1 (tag, p, 0);
451 scm_puts (": ", p);
452 scm_prin1 (args, p, 1);
453 scm_putc ('\n', p);
454 }
455 }
456
457
458 /* This is a handler function to use if you want scheme to print a
459 message and die. Useful for dealing with throws to uncaught keys
460 at the top level.
461
462 At boot time, we establish a catch-all that uses this as its handler.
463 1) If the user wants something different, they can use (catch #t
464 ...) to do what they like.
465 2) Outside the context of a read-eval-print loop, there isn't
466 anything else good to do; libguile should not assume the existence
467 of a read-eval-print loop.
468 3) Given that we shouldn't do anything complex, it's much more
469 robust to do it in C code.
470
471 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
472 message header to print; if zero, we use "guile" instead. That
473 text is followed by a colon, then the message described by ARGS. */
474
475 /* Dirk:FIXME:: The name of the function should make clear that the
476 * application gets terminated.
477 */
478
479 SCM
480 scm_handle_by_message (void *handler_data, SCM tag, SCM args)
481 {
482 if (SCM_NFALSEP (scm_eq_p (tag, scm_str2symbol ("quit"))))
483 {
484 exit (scm_exit_status (args));
485 }
486
487 handler_message (handler_data, tag, args);
488 exit (2);
489 }
490
491
492 /* This is just like scm_handle_by_message, but it doesn't exit; it
493 just returns #f. It's useful in cases where you don't really know
494 enough about the body to handle things in a better way, but don't
495 want to let throws fall off the bottom of the wind list. */
496 SCM
497 scm_handle_by_message_noexit (void *handler_data, SCM tag, SCM args)
498 {
499 handler_message (handler_data, tag, args);
500
501 return SCM_BOOL_F;
502 }
503
504
505 SCM
506 scm_handle_by_throw (void *handler_data, SCM tag, SCM args)
507 {
508 scm_ithrow (tag, args, 1);
509 return SCM_UNSPECIFIED; /* never returns */
510 }
511
512
513 \f
514 /* the Scheme-visible CATCH and LAZY-CATCH functions */
515
516 SCM_DEFINE (scm_catch, "catch", 3, 0, 0,
517 (SCM tag, SCM thunk, SCM handler),
518 "Invoke @var{thunk} in the dynamic context of @var{handler} for\n"
519 "exceptions matching @var{key}. If thunk throws to the symbol @var{key},\n"
520 "then @var{handler} is invoked this way:\n\n"
521 "@example\n"
522 "(handler key args ...)\n"
523 "@end example\n\n"
524 "@var{key} is a symbol or #t.\n\n"
525 "@var{thunk} takes no arguments. If @var{thunk} returns normally, that\n"
526 "is the return value of @code{catch}.\n\n"
527 "Handler is invoked outside the scope of its own @code{catch}. If\n"
528 "@var{handler} again throws to the same key, a new handler from further\n"
529 "up the call chain is invoked.\n\n"
530 "If the key is @code{#t}, then a throw to @emph{any} symbol will match\n"
531 "this call to @code{catch}.")
532 #define FUNC_NAME s_scm_catch
533 {
534 struct scm_body_thunk_data c;
535
536 SCM_ASSERT (SCM_SYMBOLP (tag) || SCM_EQ_P (tag, SCM_BOOL_T),
537 tag, SCM_ARG1, FUNC_NAME);
538
539 c.tag = tag;
540 c.body_proc = thunk;
541
542 /* scm_internal_catch takes care of all the mechanics of setting up
543 a catch tag; we tell it to call scm_body_thunk to run the body,
544 and scm_handle_by_proc to deal with any throws to this catch.
545 The former receives a pointer to c, telling it how to behave.
546 The latter receives a pointer to HANDLER, so it knows who to call. */
547 return scm_internal_catch (tag,
548 scm_body_thunk, &c,
549 scm_handle_by_proc, &handler);
550 }
551 #undef FUNC_NAME
552
553
554 SCM_DEFINE (scm_lazy_catch, "lazy-catch", 3, 0, 0,
555 (SCM tag, SCM thunk, SCM handler),
556 "This behaves exactly like @code{catch}, except that it does\n"
557 "not unwind the stack (this is the major difference), and if\n"
558 "handler returns, its value is returned from the throw.")
559 #define FUNC_NAME s_scm_lazy_catch
560 {
561 struct scm_body_thunk_data c;
562
563 SCM_ASSERT (SCM_SYMBOLP (tag) || SCM_EQ_P (tag, SCM_BOOL_T),
564 tag, SCM_ARG1, FUNC_NAME);
565
566 c.tag = tag;
567 c.body_proc = thunk;
568
569 /* scm_internal_lazy_catch takes care of all the mechanics of
570 setting up a lazy catch tag; we tell it to call scm_body_thunk to
571 run the body, and scm_handle_by_proc to deal with any throws to
572 this catch. The former receives a pointer to c, telling it how
573 to behave. The latter receives a pointer to HANDLER, so it knows
574 who to call. */
575 return scm_internal_lazy_catch (tag,
576 scm_body_thunk, &c,
577 scm_handle_by_proc, &handler);
578 }
579 #undef FUNC_NAME
580
581
582 \f
583 /* throwing */
584
585 SCM_DEFINE (scm_throw, "throw", 1, 0, 1,
586 (SCM key, SCM args),
587 "Invoke the catch form matching @var{key}, passing @var{args} to the\n"
588 "@var{handler}. \n\n"
589 "@var{key} is a symbol. It will match catches of the same symbol or of\n"
590 "#t.\n\n"
591 "If there is no handler at all, an error is signaled.")
592 #define FUNC_NAME s_scm_throw
593 {
594 SCM_VALIDATE_SYMBOL (1,key);
595 /* May return if handled by lazy catch. */
596 return scm_ithrow (key, args, 1);
597 }
598 #undef FUNC_NAME
599
600 SCM
601 scm_ithrow (SCM key, SCM args, int noreturn)
602 {
603 SCM jmpbuf = SCM_UNDEFINED;
604 SCM wind_goal;
605
606 SCM dynpair = SCM_UNDEFINED;
607 SCM winds;
608
609 /* Search the wind list for an appropriate catch.
610 "Waiter, please bring us the wind list." */
611 for (winds = scm_dynwinds; SCM_CONSP (winds); winds = SCM_CDR (winds))
612 {
613 dynpair = SCM_CAR (winds);
614 if (SCM_CONSP (dynpair))
615 {
616 SCM this_key = SCM_CAR (dynpair);
617
618 if (SCM_EQ_P (this_key, SCM_BOOL_T) || SCM_EQ_P (this_key, key))
619 break;
620 }
621 }
622
623 #ifdef __GNUC__
624 /* Dirk:FIXME:: This bugfix should be removed some time. */
625 /* GCC 2.95.2 has a bug in its optimizer that makes it generate
626 incorrect code sometimes. This barrier stops it from being too
627 clever. */
628 asm volatile ("" : "=g" (winds));
629 #endif
630
631 /* If we didn't find anything, print a message and abort the process
632 right here. If you don't want this, establish a catch-all around
633 any code that might throw up. */
634 if (SCM_NULLP (winds))
635 {
636 scm_handle_by_message (NULL, key, args);
637 abort ();
638 }
639
640 /* If the wind list is malformed, bail. */
641 if (!SCM_CONSP (winds))
642 abort ();
643
644 jmpbuf = SCM_CDR (dynpair);
645
646 for (wind_goal = scm_dynwinds;
647 !SCM_EQ_P (SCM_CDAR (wind_goal), jmpbuf);
648 wind_goal = SCM_CDR (wind_goal))
649 ;
650
651 /* Is a lazy catch? In wind list entries for lazy catches, the key
652 is bound to a lazy_catch smob, not a jmpbuf. */
653 if (SCM_LAZY_CATCH_P (jmpbuf))
654 {
655 struct lazy_catch *c = (struct lazy_catch *) SCM_CELL_WORD_1 (jmpbuf);
656 SCM oldwinds = scm_dynwinds;
657 SCM handle, answer;
658 scm_dowinds (wind_goal, (scm_ilength (scm_dynwinds)
659 - scm_ilength (wind_goal)));
660 SCM_REDEFER_INTS;
661 handle = scm_dynwinds;
662 scm_dynwinds = SCM_CDR (scm_dynwinds);
663 SCM_REALLOW_INTS;
664 answer = (c->handler) (c->handler_data, key, args);
665 SCM_REDEFER_INTS;
666 SCM_SETCDR (handle, scm_dynwinds);
667 scm_dynwinds = handle;
668 SCM_REALLOW_INTS;
669 scm_dowinds (oldwinds, (scm_ilength (scm_dynwinds)
670 - scm_ilength (oldwinds)));
671 return answer;
672 }
673
674 /* Otherwise, it's a normal catch. */
675 else if (SCM_JMPBUFP (jmpbuf))
676 {
677 struct jmp_buf_and_retval * jbr;
678 scm_dowinds (wind_goal, (scm_ilength (scm_dynwinds)
679 - scm_ilength (wind_goal)));
680 jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
681 jbr->throw_tag = key;
682 jbr->retval = args;
683 }
684
685 /* Otherwise, it's some random piece of junk. */
686 else
687 abort ();
688
689 #ifdef DEBUG_EXTENSIONS
690 scm_last_debug_frame = SCM_JBDFRAME (jmpbuf);
691 #endif
692 longjmp (*JBJMPBUF (jmpbuf), 1);
693 }
694
695
696 void
697 scm_init_throw ()
698 {
699 tc16_jmpbuffer = scm_make_smob_type ("jmpbuffer", 0);
700 scm_set_smob_print (tc16_jmpbuffer, jmpbuffer_print);
701
702 tc16_lazy_catch = scm_make_smob_type ("lazy-catch", 0);
703 scm_set_smob_print (tc16_lazy_catch, lazy_catch_print);
704
705 #ifndef SCM_MAGIC_SNARFER
706 #include "libguile/throw.x"
707 #endif
708 }
709
710 /*
711 Local Variables:
712 c-file-style: "gnu"
713 End:
714 */