1 /* Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
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)
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.
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
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
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.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
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.
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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
55 #include "backtrace.h"
56 #ifdef DEBUG_EXTENSIONS
59 #include "continuations.h"
64 #include "scm_validate.h"
68 /* the jump buffer data structure */
69 static int scm_tc16_jmpbuffer
;
71 #define SCM_JMPBUFP(O) (SCM_NIMP(O) && (SCM_TYP16(O) == scm_tc16_jmpbuffer))
72 #define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L))
73 #define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L)))
74 #define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L)))
76 #ifndef DEBUG_EXTENSIONS
77 #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
78 #define SETJBJMPBUF SCM_SETCDR
80 #define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) )
81 #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) )
82 #define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X))
83 #define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
88 scm_must_free ((char *) SCM_CDR (jbsmob
));
89 return sizeof (scm_cell
);
94 printjb (SCM exp
, SCM port
, scm_print_state
*pstate
)
96 scm_puts ("#<jmpbuffer ", port
);
97 scm_puts (JBACTIVE(exp
) ? "(active) " : "(inactive) ", port
);
98 scm_intprint((SCM
) JBJMPBUF(exp
), 16, port
);
110 #ifdef DEBUG_EXTENSIONS
111 char *mem
= scm_must_malloc (sizeof (scm_cell
), "jb");
113 #ifdef DEBUG_EXTENSIONS
114 SCM_NEWSMOB (answer
, scm_tc16_jmpbuffer
, mem
);
116 SCM_NEWSMOB (answer
, scm_tc16_jmpbuffer
, 0);
118 SETJBJMPBUF(answer
, (jmp_buf *)0);
119 DEACTIVATEJB(answer
);
126 /* scm_internal_catch (the guts of catch) */
128 struct jmp_buf_and_retval
/* use only on the stack, in scm_catch */
130 jmp_buf buf
; /* must be first */
136 /* scm_internal_catch is the guts of catch. It handles all the
137 mechanics of setting up a catch target, invoking the catch body,
138 and perhaps invoking the handler if the body does a throw.
140 The function is designed to be usable from C code, but is general
141 enough to implement all the semantics Guile Scheme expects from
144 TAG is the catch tag. Typically, this is a symbol, but this
145 function doesn't actually care about that.
147 BODY is a pointer to a C function which runs the body of the catch;
148 this is the code you can throw from. We call it like this:
149 BODY (BODY_DATA, JMPBUF)
151 BODY_DATA is just the BODY_DATA argument we received; we pass it
152 through to BODY as its first argument. The caller can make
153 BODY_DATA point to anything useful that BODY might need.
154 JMPBUF is the Scheme jmpbuf object corresponding to this catch,
155 which we have just created and initialized.
157 HANDLER is a pointer to a C function to deal with a throw to TAG,
158 should one occur. We call it like this:
159 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
161 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
162 same idea as BODY_DATA above.
163 THROWN_TAG is the tag that the user threw to; usually this is
164 TAG, but it could be something else if TAG was #t (i.e., a
165 catch-all), or the user threw to a jmpbuf.
166 THROW_ARGS is the list of arguments the user passed to the THROW
167 function, after the tag.
169 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
170 is just a pointer we pass through to HANDLER. We don't actually
171 use either of those pointers otherwise ourselves. The idea is
172 that, if our caller wants to communicate something to BODY or
173 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
174 HANDLER can then use. Think of it as a way to make BODY and
175 HANDLER closures, not just functions; MUMBLE_DATA points to the
178 Of course, it's up to the caller to make sure that any data a
179 MUMBLE_DATA needs is protected from GC. A common way to do this is
180 to make MUMBLE_DATA a pointer to data stored in an automatic
181 structure variable; since the collector must scan the stack for
182 references anyway, this assures that any references in MUMBLE_DATA
186 scm_internal_catch (SCM tag
, scm_catch_body_t body
, void *body_data
, scm_catch_handler_t handler
, void *handler_data
)
188 struct jmp_buf_and_retval jbr
;
192 jmpbuf
= make_jmpbuf ();
194 scm_dynwinds
= scm_acons (tag
, jmpbuf
, scm_dynwinds
);
195 SETJBJMPBUF(jmpbuf
, &jbr
.buf
);
196 #ifdef DEBUG_EXTENSIONS
197 SCM_SETJBDFRAME(jmpbuf
, scm_last_debug_frame
);
199 if (setjmp (jbr
.buf
))
204 #ifdef STACK_CHECKING
205 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
208 DEACTIVATEJB (jmpbuf
);
209 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
211 throw_args
= jbr
.retval
;
212 throw_tag
= jbr
.throw_tag
;
213 jbr
.throw_tag
= SCM_EOL
;
214 jbr
.retval
= SCM_EOL
;
215 answer
= handler (handler_data
, throw_tag
, throw_args
);
220 answer
= body (body_data
);
222 DEACTIVATEJB (jmpbuf
);
223 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
231 /* scm_internal_lazy_catch (the guts of lazy catching) */
233 /* The smob tag for lazy_catch smobs. */
234 static long tc16_lazy_catch
;
236 /* This is the structure we put on the wind list for a lazy catch. It
237 stores the handler function to call, and the data pointer to pass
238 through to it. It's not a Scheme closure, but it is a function
239 with data, so the term "closure" is appropriate in its broader
242 (We don't need anything like this in the "eager" catch code,
243 because the same C frame runs both the body and the handler.) */
245 scm_catch_handler_t handler
;
249 /* Strictly speaking, we could just pass a zero for our print
250 function, because we don't need to print them. They should never
251 appear in normal data structures, only in the wind list. However,
252 it might be nice for debugging someday... */
254 print_lazy_catch (SCM closure
, SCM port
, scm_print_state
*pstate
)
256 struct lazy_catch
*c
= (struct lazy_catch
*) SCM_CDR (closure
);
259 sprintf (buf
, "#<lazy-catch 0x%lx 0x%lx>",
260 (long) c
->handler
, (long) c
->handler_data
);
261 scm_puts (buf
, port
);
267 /* Given a pointer to a lazy catch structure, return a smob for it,
268 suitable for inclusion in the wind list. ("Ah yes, a Château
269 Gollombiere '72, non?"). */
271 make_lazy_catch (struct lazy_catch
*c
)
273 SCM_RETURN_NEWSMOB (tc16_lazy_catch
, c
);
276 #define SCM_LAZY_CATCH_P(obj) \
277 (SCM_NIMP (obj) && (SCM_CAR (obj) == tc16_lazy_catch))
280 /* Exactly like scm_internal_catch, except:
281 - It does not unwind the stack (this is the major difference).
282 - If handler returns, its value is returned from the throw. */
284 scm_internal_lazy_catch (SCM tag
, scm_catch_body_t body
, void *body_data
, scm_catch_handler_t handler
, void *handler_data
)
286 SCM lazy_catch
, answer
;
290 c
.handler_data
= handler_data
;
291 lazy_catch
= make_lazy_catch (&c
);
294 scm_dynwinds
= scm_acons (tag
, lazy_catch
, scm_dynwinds
);
297 answer
= (*body
) (body_data
);
300 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
307 /* scm_internal_stack_catch
308 Use this one if you want debugging information to be stored in
309 scm_the_last_stack_fluid on error. */
312 ss_handler (void *data
, SCM tag
, SCM throw_args
)
315 scm_fluid_set_x (SCM_CDR (scm_the_last_stack_fluid
),
316 scm_make_stack (scm_cons (SCM_BOOL_T
, SCM_EOL
)));
317 /* Throw the error */
318 return scm_throw (tag
, throw_args
);
324 scm_catch_body_t body
;
329 cwss_body (void *data
)
331 struct cwss_data
*d
= data
;
332 return scm_internal_lazy_catch (d
->tag
, d
->body
, d
->data
, ss_handler
, NULL
);
336 scm_internal_stack_catch (SCM tag
,
337 scm_catch_body_t body
,
339 scm_catch_handler_t handler
,
346 return scm_internal_catch (tag
, cwss_body
, &d
, handler
, handler_data
);
351 /* body and handler functions for use with any of the above catch variants */
353 /* This is a body function you can pass to scm_internal_catch if you
354 want the body to be like Scheme's `catch' --- a thunk.
356 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
357 contains the Scheme procedure to invoke as the body, and the tag
361 scm_body_thunk (void *body_data
)
363 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
365 return scm_apply (c
->body_proc
, SCM_EOL
, SCM_EOL
);
369 /* This is a handler function you can pass to scm_internal_catch if
370 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
371 applies a handler procedure to (TAG ARGS ...).
373 If the user does a throw to this catch, this function runs a
374 handler procedure written in Scheme. HANDLER_DATA is a pointer to
375 an SCM variable holding the Scheme procedure object to invoke. It
376 ought to be a pointer to an automatic variable (i.e., one living on
377 the stack), or the procedure object should be otherwise protected
380 scm_handle_by_proc (void *handler_data
, SCM tag
, SCM throw_args
)
382 SCM
*handler_proc_p
= (SCM
*) handler_data
;
384 return scm_apply (*handler_proc_p
, scm_cons (tag
, throw_args
), SCM_EOL
);
387 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
388 catches all throws that the handler might emit itself. The handler
389 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
397 hbpca_body (void *body_data
)
399 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
400 return scm_apply (data
->proc
, data
->args
, SCM_EOL
);
404 scm_handle_by_proc_catching_all (void *handler_data
, SCM tag
, SCM throw_args
)
406 SCM
*handler_proc_p
= (SCM
*) handler_data
;
407 struct hbpca_data data
;
408 data
.proc
= *handler_proc_p
;
409 data
.args
= scm_cons (tag
, throw_args
);
411 return scm_internal_catch (SCM_BOOL_T
,
413 scm_handle_by_message_noexit
, NULL
);
416 /* Derive the an exit status from the arguments to (quit ...). */
418 scm_exit_status (SCM args
)
420 if (SCM_NNULLP (args
))
422 SCM cqa
= SCM_CAR (args
);
425 return (SCM_INUM (cqa
));
426 else if (SCM_FALSEP (cqa
))
434 handler_message (void *handler_data
, SCM tag
, SCM args
)
436 char *prog_name
= (char *) handler_data
;
437 SCM p
= scm_cur_errp
;
439 if (scm_ilength (args
) >= 3)
441 SCM stack
= scm_make_stack (SCM_LIST1 (SCM_BOOL_T
));
442 SCM subr
= SCM_CAR (args
);
443 SCM message
= SCM_CADR (args
);
444 SCM parts
= SCM_CADDR (args
);
445 SCM rest
= SCM_CDDDR (args
);
447 if (SCM_BACKTRACE_P
&& SCM_NFALSEP (stack
))
449 scm_puts ("Backtrace:\n", p
);
450 scm_display_backtrace (stack
, p
, SCM_UNDEFINED
, SCM_UNDEFINED
);
453 scm_display_error (stack
, p
, subr
, message
, parts
, rest
);
460 scm_puts (prog_name
, p
);
463 scm_puts ("uncaught throw to ", p
);
464 scm_prin1 (tag
, p
, 0);
466 scm_prin1 (args
, p
, 1);
472 /* This is a handler function to use if you want scheme to print a
473 message and die. Useful for dealing with throws to uncaught keys
476 At boot time, we establish a catch-all that uses this as its handler.
477 1) If the user wants something different, they can use (catch #t
478 ...) to do what they like.
479 2) Outside the context of a read-eval-print loop, there isn't
480 anything else good to do; libguile should not assume the existence
481 of a read-eval-print loop.
482 3) Given that we shouldn't do anything complex, it's much more
483 robust to do it in C code.
485 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
486 message header to print; if zero, we use "guile" instead. That
487 text is followed by a colon, then the message described by ARGS. */
490 scm_handle_by_message (void *handler_data
, SCM tag
, SCM args
)
492 if (SCM_NFALSEP (scm_eq_p (tag
, SCM_CAR (scm_intern0 ("quit")))))
494 exit (scm_exit_status (args
));
497 handler_message (handler_data
, tag
, args
);
498 /* try to flush the error message first before the rest of the
499 ports: if any throw error, it currently causes a bus
505 /* This is just like scm_handle_by_message, but it doesn't exit; it
506 just returns #f. It's useful in cases where you don't really know
507 enough about the body to handle things in a better way, but don't
508 want to let throws fall off the bottom of the wind list. */
510 scm_handle_by_message_noexit (void *handler_data
, SCM tag
, SCM args
)
512 handler_message (handler_data
, tag
, args
);
519 scm_handle_by_throw (void *handler_data
, SCM tag
, SCM args
)
521 scm_ithrow (tag
, args
, 1);
522 return SCM_UNSPECIFIED
; /* never returns */
527 /* the Scheme-visible CATCH and LAZY-CATCH functions */
529 GUILE_PROC(scm_catch
, "catch", 3, 0, 0,
530 (SCM tag
, SCM thunk
, SCM handler
),
531 "Invoke @var{thunk} in the dynamic context of @var{handler} for
532 exceptions matching @var{key}. If thunk throws to the symbol @var{key},
533 then @var{handler} is invoked this way:
536 (handler key args ...)
539 @var{key} is a symbol or #t.
541 @var{thunk} takes no arguments. If @var{thunk} returns normally, that
542 is the return value of @code{catch}.
544 Handler is invoked outside the scope of its own @code{catch}. If
545 @var{handler} again throws to the same key, a new handler from further
546 up the call chain is invoked.
548 If the key is @code{#t}, then a throw to @emph{any} symbol will match
549 this call to @code{catch}.")
550 #define FUNC_NAME s_scm_catch
552 struct scm_body_thunk_data c
;
554 SCM_ASSERT ((SCM_NIMP(tag
) && SCM_SYMBOLP(tag
)) || tag
== SCM_BOOL_T
,
555 tag
, SCM_ARG1
, FUNC_NAME
);
560 /* scm_internal_catch takes care of all the mechanics of setting up
561 a catch tag; we tell it to call scm_body_thunk to run the body,
562 and scm_handle_by_proc to deal with any throws to this catch.
563 The former receives a pointer to c, telling it how to behave.
564 The latter receives a pointer to HANDLER, so it knows who to call. */
565 return scm_internal_catch (tag
,
567 scm_handle_by_proc
, &handler
);
572 GUILE_PROC(scm_lazy_catch
, "lazy-catch", 3, 0, 0,
573 (SCM tag
, SCM thunk
, SCM handler
),
575 #define FUNC_NAME s_scm_lazy_catch
577 struct scm_body_thunk_data c
;
579 SCM_ASSERT ((SCM_NIMP(tag
) && SCM_SYMBOLP(tag
))
580 || (tag
== SCM_BOOL_T
),
581 tag
, SCM_ARG1
, FUNC_NAME
);
586 /* scm_internal_lazy_catch takes care of all the mechanics of
587 setting up a lazy catch tag; we tell it to call scm_body_thunk to
588 run the body, and scm_handle_by_proc to deal with any throws to
589 this catch. The former receives a pointer to c, telling it how
590 to behave. The latter receives a pointer to HANDLER, so it knows
592 return scm_internal_lazy_catch (tag
,
594 scm_handle_by_proc
, &handler
);
602 GUILE_PROC(scm_throw
, "throw", 1, 0, 1,
604 "Invoke the catch form matching @var{key}, passing @var{args} to the
607 @var{key} is a symbol. It will match catches of the same symbol or of
610 If there is no handler at all, an error is signaled.")
611 #define FUNC_NAME s_scm_throw
613 SCM_VALIDATE_SYMBOL(1,key
);
614 /* May return if handled by lazy catch. */
615 return scm_ithrow (key
, args
, 1);
621 scm_ithrow (SCM key
, SCM args
, int noreturn
)
623 SCM jmpbuf
= SCM_UNDEFINED
;
626 SCM dynpair
= SCM_UNDEFINED
;
629 /* Search the wind list for an appropriate catch.
630 "Waiter, please bring us the wind list." */
631 for (winds
= scm_dynwinds
; SCM_NIMP (winds
); winds
= SCM_CDR (winds
))
633 if (! SCM_CONSP (winds
))
636 dynpair
= SCM_CAR (winds
);
637 if (SCM_NIMP (dynpair
) && SCM_CONSP (dynpair
))
639 SCM this_key
= SCM_CAR (dynpair
);
641 if (this_key
== SCM_BOOL_T
|| this_key
== key
)
646 /* If we didn't find anything, abort. scm_boot_guile should
647 have established a catch-all, but obviously things are
648 thoroughly screwed up. */
649 if (winds
== SCM_EOL
)
652 /* If the wind list is malformed, bail. */
653 if (SCM_IMP (winds
) || SCM_NCONSP (winds
))
656 if (dynpair
!= SCM_BOOL_F
)
657 jmpbuf
= SCM_CDR (dynpair
);
661 return SCM_UNSPECIFIED
;
664 scm_exitval
= scm_cons (key
, args
);
665 scm_dowinds (SCM_EOL
, scm_ilength (scm_dynwinds
));
666 #ifdef DEBUG_EXTENSIONS
667 scm_last_debug_frame
= SCM_DFRAME (scm_rootcont
);
669 longjmp (SCM_JMPBUF (scm_rootcont
), 1);
673 for (wind_goal
= scm_dynwinds
;
674 SCM_CDAR (wind_goal
) != jmpbuf
;
675 wind_goal
= SCM_CDR (wind_goal
))
678 /* Is a lazy catch? In wind list entries for lazy catches, the key
679 is bound to a lazy_catch smob, not a jmpbuf. */
680 if (SCM_LAZY_CATCH_P (jmpbuf
))
682 struct lazy_catch
*c
= (struct lazy_catch
*) SCM_CDR (jmpbuf
);
683 SCM oldwinds
= scm_dynwinds
;
685 scm_dowinds (wind_goal
, (scm_ilength (scm_dynwinds
)
686 - scm_ilength (wind_goal
)));
688 handle
= scm_dynwinds
;
689 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
691 answer
= (c
->handler
) (c
->handler_data
, key
, args
);
693 SCM_SETCDR (handle
, scm_dynwinds
);
694 scm_dynwinds
= handle
;
696 scm_dowinds (oldwinds
, (scm_ilength (scm_dynwinds
)
697 - scm_ilength (oldwinds
)));
701 /* Otherwise, it's a normal catch. */
702 else if (SCM_JMPBUFP (jmpbuf
))
704 struct jmp_buf_and_retval
* jbr
;
705 scm_dowinds (wind_goal
, (scm_ilength (scm_dynwinds
)
706 - scm_ilength (wind_goal
)));
707 jbr
= (struct jmp_buf_and_retval
*)JBJMPBUF (jmpbuf
);
708 jbr
->throw_tag
= key
;
712 /* Otherwise, it's some random piece of junk. */
716 #ifdef DEBUG_EXTENSIONS
717 scm_last_debug_frame
= SCM_JBDFRAME (jmpbuf
);
719 longjmp (*JBJMPBUF (jmpbuf
), 1);
726 #ifdef DEBUG_EXTENSIONS
727 scm_tc16_jmpbuffer
= scm_make_smob_type_mfpe ("jmpbuffer",
734 scm_tc16_jmpbuffer
= scm_make_smob_type_mfpe ("jmpbuffer",
742 tc16_lazy_catch
= scm_make_smob_type_mfpe ("lazy-catch", 0,