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. */
51 #include "backtrace.h"
52 #ifdef DEBUG_EXTENSIONS
55 #include "continuations.h"
63 /* the jump buffer data structure */
64 static int scm_tc16_jmpbuffer
;
66 #define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer)
67 #define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L))
68 #define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L)))
69 #define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L)))
71 #ifndef DEBUG_EXTENSIONS
72 #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
73 #define SETJBJMPBUF SCM_SETCDR
75 #define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) )
76 #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) )
77 #define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X))
78 #define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
80 static scm_sizet freejb
SCM_P ((SCM jbsmob
));
86 scm_must_free ((char *) SCM_CDR (jbsmob
));
87 return sizeof (scm_cell
);
91 static int printjb
SCM_P ((SCM exp
, SCM port
, scm_print_state
*pstate
));
93 printjb (exp
, port
, pstate
)
96 scm_print_state
*pstate
;
98 scm_puts ("#<jmpbuffer ", port
);
99 scm_puts (JBACTIVE(exp
) ? "(active) " : "(inactive) ", port
);
100 scm_intprint((SCM
) JBJMPBUF(exp
), 16, port
);
101 scm_putc ('>', port
);
106 static SCM make_jmpbuf
SCM_P ((void));
113 #ifdef DEBUG_EXTENSIONS
114 char *mem
= scm_must_malloc (sizeof (scm_cell
), "jb");
116 #ifdef DEBUG_EXTENSIONS
117 SCM_NEWSMOB (answer
, scm_tc16_jmpbuffer
, mem
);
119 SCM_NEWSMOB (answer
, scm_tc16_jmpbuffer
, 0);
121 SETJBJMPBUF(answer
, (jmp_buf *)0);
122 DEACTIVATEJB(answer
);
129 /* scm_internal_catch (the guts of catch) */
131 struct jmp_buf_and_retval
/* use only on the stack, in scm_catch */
133 jmp_buf buf
; /* must be first */
139 /* scm_internal_catch is the guts of catch. It handles all the
140 mechanics of setting up a catch target, invoking the catch body,
141 and perhaps invoking the handler if the body does a throw.
143 The function is designed to be usable from C code, but is general
144 enough to implement all the semantics Guile Scheme expects from
147 TAG is the catch tag. Typically, this is a symbol, but this
148 function doesn't actually care about that.
150 BODY is a pointer to a C function which runs the body of the catch;
151 this is the code you can throw from. We call it like this:
152 BODY (BODY_DATA, JMPBUF)
154 BODY_DATA is just the BODY_DATA argument we received; we pass it
155 through to BODY as its first argument. The caller can make
156 BODY_DATA point to anything useful that BODY might need.
157 JMPBUF is the Scheme jmpbuf object corresponding to this catch,
158 which we have just created and initialized.
160 HANDLER is a pointer to a C function to deal with a throw to TAG,
161 should one occur. We call it like this:
162 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
164 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
165 same idea as BODY_DATA above.
166 THROWN_TAG is the tag that the user threw to; usually this is
167 TAG, but it could be something else if TAG was #t (i.e., a
168 catch-all), or the user threw to a jmpbuf.
169 THROW_ARGS is the list of arguments the user passed to the THROW
170 function, after the tag.
172 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
173 is just a pointer we pass through to HANDLER. We don't actually
174 use either of those pointers otherwise ourselves. The idea is
175 that, if our caller wants to communicate something to BODY or
176 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
177 HANDLER can then use. Think of it as a way to make BODY and
178 HANDLER closures, not just functions; MUMBLE_DATA points to the
181 Of course, it's up to the caller to make sure that any data a
182 MUMBLE_DATA needs is protected from GC. A common way to do this is
183 to make MUMBLE_DATA a pointer to data stored in an automatic
184 structure variable; since the collector must scan the stack for
185 references anyway, this assures that any references in MUMBLE_DATA
189 scm_internal_catch (tag
, body
, body_data
, handler
, handler_data
)
191 scm_catch_body_t body
;
193 scm_catch_handler_t handler
;
196 struct jmp_buf_and_retval jbr
;
200 jmpbuf
= make_jmpbuf ();
202 scm_dynwinds
= scm_acons (tag
, jmpbuf
, scm_dynwinds
);
203 SETJBJMPBUF(jmpbuf
, &jbr
.buf
);
204 #ifdef DEBUG_EXTENSIONS
205 SCM_SETJBDFRAME(jmpbuf
, scm_last_debug_frame
);
207 if (setjmp (jbr
.buf
))
212 #ifdef STACK_CHECKING
213 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
216 DEACTIVATEJB (jmpbuf
);
217 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
219 throw_args
= jbr
.retval
;
220 throw_tag
= jbr
.throw_tag
;
221 jbr
.throw_tag
= SCM_EOL
;
222 jbr
.retval
= SCM_EOL
;
223 answer
= handler (handler_data
, throw_tag
, throw_args
);
228 answer
= body (body_data
);
230 DEACTIVATEJB (jmpbuf
);
231 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
239 /* scm_internal_lazy_catch (the guts of lazy catching) */
241 /* The smob tag for lazy_catch smobs. */
242 static long tc16_lazy_catch
;
244 /* This is the structure we put on the wind list for a lazy catch. It
245 stores the handler function to call, and the data pointer to pass
246 through to it. It's not a Scheme closure, but it is a function
247 with data, so the term "closure" is appropriate in its broader
250 (We don't need anything like this in the "eager" catch code,
251 because the same C frame runs both the body and the handler.) */
253 scm_catch_handler_t handler
;
257 /* Strictly speaking, we could just pass a zero for our print
258 function, because we don't need to print them. They should never
259 appear in normal data structures, only in the wind list. However,
260 it might be nice for debugging someday... */
262 print_lazy_catch (SCM closure
, SCM port
, scm_print_state
*pstate
)
264 struct lazy_catch
*c
= (struct lazy_catch
*) SCM_CDR (closure
);
267 sprintf (buf
, "#<lazy-catch 0x%lx 0x%lx>",
268 (long) c
->handler
, (long) c
->handler_data
);
269 scm_puts (buf
, port
);
275 /* Given a pointer to a lazy catch structure, return a smob for it,
276 suitable for inclusion in the wind list. ("Ah yes, a Château
277 Gollombiere '72, non?"). */
279 make_lazy_catch (struct lazy_catch
*c
)
281 SCM_RETURN_NEWSMOB (tc16_lazy_catch
, c
);
284 #define SCM_LAZY_CATCH_P(obj) \
285 (SCM_NIMP (obj) && (SCM_CAR (obj) == tc16_lazy_catch))
288 /* Exactly like scm_internal_catch, except:
289 - It does not unwind the stack (this is the major difference).
290 - If handler returns, its value is returned from the throw. */
292 scm_internal_lazy_catch (tag
, body
, body_data
, handler
, handler_data
)
294 scm_catch_body_t body
;
296 scm_catch_handler_t handler
;
299 SCM lazy_catch
, answer
;
303 c
.handler_data
= handler_data
;
304 lazy_catch
= make_lazy_catch (&c
);
307 scm_dynwinds
= scm_acons (tag
, lazy_catch
, scm_dynwinds
);
310 answer
= (*body
) (body_data
);
313 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
320 /* scm_internal_stack_catch
321 Use this one if you want debugging information to be stored in
322 scm_the_last_stack_fluid on error. */
325 ss_handler (void *data
, SCM tag
, SCM throw_args
)
328 scm_fluid_set_x (SCM_CDR (scm_the_last_stack_fluid
),
329 scm_make_stack (scm_cons (SCM_BOOL_T
, SCM_EOL
)));
330 /* Throw the error */
331 return scm_throw (tag
, throw_args
);
337 scm_catch_body_t body
;
342 cwss_body (void *data
)
344 struct cwss_data
*d
= data
;
345 return scm_internal_lazy_catch (d
->tag
, d
->body
, d
->data
, ss_handler
, NULL
);
349 scm_internal_stack_catch (SCM tag
,
350 scm_catch_body_t body
,
352 scm_catch_handler_t handler
,
359 return scm_internal_catch (tag
, cwss_body
, &d
, handler
, handler_data
);
364 /* body and handler functions for use with any of the above catch variants */
366 /* This is a body function you can pass to scm_internal_catch if you
367 want the body to be like Scheme's `catch' --- a thunk.
369 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
370 contains the Scheme procedure to invoke as the body, and the tag
374 scm_body_thunk (body_data
)
377 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
379 return scm_apply (c
->body_proc
, SCM_EOL
, SCM_EOL
);
383 /* This is a handler function you can pass to scm_internal_catch if
384 you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
385 applies a handler procedure to (TAG ARGS ...).
387 If the user does a throw to this catch, this function runs a
388 handler procedure written in Scheme. HANDLER_DATA is a pointer to
389 an SCM variable holding the Scheme procedure object to invoke. It
390 ought to be a pointer to an automatic variable (i.e., one living on
391 the stack), or the procedure object should be otherwise protected
394 scm_handle_by_proc (handler_data
, tag
, throw_args
)
399 SCM
*handler_proc_p
= (SCM
*) handler_data
;
401 return scm_apply (*handler_proc_p
, scm_cons (tag
, throw_args
), SCM_EOL
);
404 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
405 catches all throws that the handler might emit itself. The handler
406 used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT. */
414 hbpca_body (body_data
)
417 struct hbpca_data
*data
= (struct hbpca_data
*)body_data
;
418 return scm_apply (data
->proc
, data
->args
, SCM_EOL
);
422 scm_handle_by_proc_catching_all (handler_data
, tag
, throw_args
)
427 SCM
*handler_proc_p
= (SCM
*) handler_data
;
428 struct hbpca_data data
;
429 data
.proc
= *handler_proc_p
;
430 data
.args
= scm_cons (tag
, throw_args
);
432 return scm_internal_catch (SCM_BOOL_T
,
434 scm_handle_by_message_noexit
, NULL
);
437 /* Derive the an exit status from the arguments to (quit ...). */
439 scm_exit_status (args
)
442 if (SCM_NNULLP (args
))
444 SCM cqa
= SCM_CAR (args
);
447 return (SCM_INUM (cqa
));
448 else if (SCM_FALSEP (cqa
))
456 handler_message (void *handler_data
, SCM tag
, SCM args
)
458 char *prog_name
= (char *) handler_data
;
459 SCM p
= scm_cur_errp
;
461 if (scm_ilength (args
) >= 3)
463 SCM stack
= scm_make_stack (SCM_LIST1 (SCM_BOOL_T
));
464 SCM subr
= SCM_CAR (args
);
465 SCM message
= SCM_CADR (args
);
466 SCM parts
= SCM_CADDR (args
);
467 SCM rest
= SCM_CDDDR (args
);
469 scm_display_error (stack
, p
, subr
, message
, parts
, rest
);
476 scm_puts (prog_name
, p
);
479 scm_puts ("uncaught throw to ", p
);
480 scm_prin1 (tag
, p
, 0);
482 scm_prin1 (args
, p
, 1);
488 /* This is a handler function to use if you want scheme to print a
489 message and die. Useful for dealing with throws to uncaught keys
492 At boot time, we establish a catch-all that uses this as its handler.
493 1) If the user wants something different, they can use (catch #t
494 ...) to do what they like.
495 2) Outside the context of a read-eval-print loop, there isn't
496 anything else good to do; libguile should not assume the existence
497 of a read-eval-print loop.
498 3) Given that we shouldn't do anything complex, it's much more
499 robust to do it in C code.
501 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
502 message header to print; if zero, we use "guile" instead. That
503 text is followed by a colon, then the message described by ARGS. */
506 scm_handle_by_message (handler_data
, tag
, args
)
511 if (SCM_NFALSEP (scm_eq_p (tag
, SCM_CAR (scm_intern0 ("quit")))))
513 exit (scm_exit_status (args
));
516 handler_message (handler_data
, tag
, args
);
517 /* try to flush the error message first before the rest of the
518 ports: if any throw error, it currently causes a bus
524 /* This is just like scm_handle_by_message, but it doesn't exit; it
525 just returns #f. It's useful in cases where you don't really know
526 enough about the body to handle things in a better way, but don't
527 want to let throws fall off the bottom of the wind list. */
529 scm_handle_by_message_noexit (handler_data
, tag
, args
)
534 handler_message (handler_data
, tag
, args
);
541 scm_handle_by_throw (handler_data
, tag
, args
)
546 scm_ithrow (tag
, args
, 1);
547 return SCM_UNSPECIFIED
; /* never returns */
552 /* the Scheme-visible CATCH and LAZY-CATCH functions */
554 SCM_PROC(s_catch
, "catch", 3, 0, 0, scm_catch
);
556 scm_catch (tag
, thunk
, handler
)
561 struct scm_body_thunk_data c
;
563 SCM_ASSERT ((SCM_NIMP(tag
) && SCM_SYMBOLP(tag
)) || tag
== SCM_BOOL_T
,
571 /* scm_internal_catch takes care of all the mechanics of setting up
572 a catch tag; we tell it to call scm_body_thunk to run the body,
573 and scm_handle_by_proc to deal with any throws to this catch.
574 The former receives a pointer to c, telling it how to behave.
575 The latter receives a pointer to HANDLER, so it knows who to call. */
576 return scm_internal_catch (tag
,
578 scm_handle_by_proc
, &handler
);
582 SCM_PROC(s_lazy_catch
, "lazy-catch", 3, 0, 0, scm_lazy_catch
);
584 scm_lazy_catch (tag
, thunk
, handler
)
589 struct scm_body_thunk_data c
;
591 SCM_ASSERT ((SCM_NIMP(tag
) && SCM_SYMBOLP(tag
))
592 || (tag
== SCM_BOOL_T
),
593 tag
, SCM_ARG1
, s_lazy_catch
);
598 /* scm_internal_lazy_catch takes care of all the mechanics of
599 setting up a lazy catch tag; we tell it to call scm_body_thunk to
600 run the body, and scm_handle_by_proc to deal with any throws to
601 this catch. The former receives a pointer to c, telling it how
602 to behave. The latter receives a pointer to HANDLER, so it knows
604 return scm_internal_lazy_catch (tag
,
606 scm_handle_by_proc
, &handler
);
613 SCM_PROC(s_throw
, "throw", 1, 0, 1, scm_throw
);
615 scm_throw (key
, args
)
619 SCM_ASSERT (SCM_NIMP (key
) && SCM_SYMBOLP (key
), key
, SCM_ARG1
, s_throw
);
620 /* May return if handled by lazy catch. */
621 return scm_ithrow (key
, args
, 1);
626 scm_ithrow (key
, args
, noreturn
)
631 SCM jmpbuf
= SCM_UNDEFINED
;
634 SCM dynpair
= SCM_UNDEFINED
;
637 /* Search the wind list for an appropriate catch.
638 "Waiter, please bring us the wind list." */
639 for (winds
= scm_dynwinds
; SCM_NIMP (winds
); winds
= SCM_CDR (winds
))
641 if (! SCM_CONSP (winds
))
644 dynpair
= SCM_CAR (winds
);
645 if (SCM_NIMP (dynpair
) && SCM_CONSP (dynpair
))
647 SCM this_key
= SCM_CAR (dynpair
);
649 if (this_key
== SCM_BOOL_T
|| this_key
== key
)
654 /* If we didn't find anything, abort. scm_boot_guile should
655 have established a catch-all, but obviously things are
656 thoroughly screwed up. */
657 if (winds
== SCM_EOL
)
660 /* If the wind list is malformed, bail. */
661 if (SCM_IMP (winds
) || SCM_NCONSP (winds
))
664 if (dynpair
!= SCM_BOOL_F
)
665 jmpbuf
= SCM_CDR (dynpair
);
669 return SCM_UNSPECIFIED
;
672 scm_exitval
= scm_cons (key
, args
);
673 scm_dowinds (SCM_EOL
, scm_ilength (scm_dynwinds
));
674 #ifdef DEBUG_EXTENSIONS
675 scm_last_debug_frame
= SCM_DFRAME (scm_rootcont
);
677 longjmp (SCM_JMPBUF (scm_rootcont
), 1);
681 for (wind_goal
= scm_dynwinds
;
682 SCM_CDAR (wind_goal
) != jmpbuf
;
683 wind_goal
= SCM_CDR (wind_goal
))
686 /* Is a lazy catch? In wind list entries for lazy catches, the key
687 is bound to a lazy_catch smob, not a jmpbuf. */
688 if (SCM_LAZY_CATCH_P (jmpbuf
))
690 struct lazy_catch
*c
= (struct lazy_catch
*) SCM_CDR (jmpbuf
);
691 SCM oldwinds
= scm_dynwinds
;
693 scm_dowinds (wind_goal
, (scm_ilength (scm_dynwinds
)
694 - scm_ilength (wind_goal
)));
696 handle
= scm_dynwinds
;
697 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
699 answer
= (c
->handler
) (c
->handler_data
, key
, args
);
701 SCM_SETCDR (handle
, scm_dynwinds
);
702 scm_dynwinds
= handle
;
704 scm_dowinds (oldwinds
, (scm_ilength (scm_dynwinds
)
705 - scm_ilength (oldwinds
)));
709 /* Otherwise, it's a normal catch. */
710 else if (SCM_JMPBUFP (jmpbuf
))
712 struct jmp_buf_and_retval
* jbr
;
713 scm_dowinds (wind_goal
, (scm_ilength (scm_dynwinds
)
714 - scm_ilength (wind_goal
)));
715 jbr
= (struct jmp_buf_and_retval
*)JBJMPBUF (jmpbuf
);
716 jbr
->throw_tag
= key
;
720 /* Otherwise, it's some random piece of junk. */
724 #ifdef DEBUG_EXTENSIONS
725 scm_last_debug_frame
= SCM_JBDFRAME (jmpbuf
);
727 longjmp (*JBJMPBUF (jmpbuf
), 1);
734 #ifdef DEBUG_EXTENSIONS
735 scm_tc16_jmpbuffer
= scm_make_smob_type_mfpe ("jmpbuffer",
742 scm_tc16_jmpbuffer
= scm_make_smob_type_mfpe ("jmpbuffer",
750 tc16_lazy_catch
= scm_make_smob_type_mfpe ("lazy-catch", 0,