1 /* Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
17 * As a special exception, the Free Software Foundation gives permission
18 * for additional uses of the text contained in its release of GUILE.
20 * The exception is that, if you link the GUILE library with other files
21 * to produce an executable, this does not by itself cause the
22 * resulting executable to be covered by the GNU General Public License.
23 * Your use of that executable is in no way restricted on account of
24 * linking the GUILE library code into it.
26 * This exception does not however invalidate any other reasons why
27 * the executable file might be covered by the GNU General Public License.
29 * This exception applies only to the code released by the
30 * Free Software Foundation under the name GUILE. If you copy
31 * code from other Free Software Foundation releases into a copy of
32 * GUILE, as the General Public License permits, the exception does
33 * not apply to the code that you add in this way. To avoid misleading
34 * anyone as to the status of such modified files, you must delete
35 * this exception notice from them.
37 * If you write modifications of your own for GUILE, it is your choice
38 * whether to permit this exception to apply to your modifications.
39 * If you do not wish that, delete this exception notice.
51 #include "backtrace.h"
52 #ifdef DEBUG_EXTENSIONS
55 #include "continuations.h"
61 /* the jump buffer data structure */
62 static int scm_tc16_jmpbuffer
;
64 #define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer)
65 #define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L))
66 #define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L)))
67 #define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L)))
69 #ifndef DEBUG_EXTENSIONS
70 #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
71 #define SETJBJMPBUF SCM_SETCDR
73 #define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) )
74 #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) )
75 #define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X))
76 #define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
78 static scm_sizet freejb
SCM_P ((SCM jbsmob
));
84 scm_must_free ((char *) SCM_CDR (jbsmob
));
85 return sizeof (scm_cell
);
89 static int printjb
SCM_P ((SCM exp
, SCM port
, scm_print_state
*pstate
));
91 printjb (exp
, port
, pstate
)
94 scm_print_state
*pstate
;
96 scm_gen_puts (scm_regular_string
, "#<jmpbuffer ", port
);
97 scm_gen_puts (scm_regular_string
, JBACTIVE(exp
) ? "(active) " : "(inactive) ", port
);
98 scm_intprint((SCM
) JBJMPBUF(exp
), 16, port
);
99 scm_gen_putc ('>', port
);
103 static scm_smobfuns jbsmob
= {
105 #ifdef DEBUG_EXTENSIONS
114 static SCM make_jmpbuf
SCM_P ((void));
119 SCM_NEWCELL (answer
);
122 #ifdef DEBUG_EXTENSIONS
123 char *mem
= scm_must_malloc (sizeof (scm_cell
), "jb");
124 SCM_SETCDR (answer
, (SCM
) mem
);
126 SCM_SETCAR (answer
, scm_tc16_jmpbuffer
);
127 SETJBJMPBUF(answer
, (jmp_buf *)0);
128 DEACTIVATEJB(answer
);
135 /* scm_internal_catch (the guts of catch) */
137 struct jmp_buf_and_retval
/* use only on the stack, in scm_catch */
139 jmp_buf buf
; /* must be first */
145 /* scm_internal_catch is the guts of catch. It handles all the
146 mechanics of setting up a catch target, invoking the catch body,
147 and perhaps invoking the handler if the body does a throw.
149 The function is designed to be usable from C code, but is general
150 enough to implement all the semantics Guile Scheme expects from
153 TAG is the catch tag. Typically, this is a symbol, but this
154 function doesn't actually care about that.
156 BODY is a pointer to a C function which runs the body of the catch;
157 this is the code you can throw from. We call it like this:
158 BODY (BODY_DATA, JMPBUF)
160 BODY_DATA is just the BODY_DATA argument we received; we pass it
161 through to BODY as its first argument. The caller can make
162 BODY_DATA point to anything useful that BODY might need.
163 JMPBUF is the Scheme jmpbuf object corresponding to this catch,
164 which we have just created and initialized.
166 HANDLER is a pointer to a C function to deal with a throw to TAG,
167 should one occur. We call it like this:
168 HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
170 HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
171 same idea as BODY_DATA above.
172 THROWN_TAG is the tag that the user threw to; usually this is
173 TAG, but it could be something else if TAG was #t (i.e., a
174 catch-all), or the user threw to a jmpbuf.
175 THROW_ARGS is the list of arguments the user passed to the THROW
178 BODY_DATA is just a pointer we pass through to BODY. HANDLER_DATA
179 is just a pointer we pass through to HANDLER. We don't actually
180 use either of those pointers otherwise ourselves. The idea is
181 that, if our caller wants to communicate something to BODY or
182 HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
183 HANDLER can then use. Think of it as a way to make BODY and
184 HANDLER closures, not just functions; MUMBLE_DATA points to the
187 Of course, it's up to the caller to make sure that any data a
188 MUMBLE_DATA needs is protected from GC. A common way to do this is
189 to make MUMBLE_DATA a pointer to data stored in an automatic
190 structure variable; since the collector must scan the stack for
191 references anyway, this assures that any references in MUMBLE_DATA
195 scm_internal_catch (tag
, body
, body_data
, handler
, handler_data
)
197 scm_catch_body_t body
;
199 scm_catch_handler_t handler
;
202 struct jmp_buf_and_retval jbr
;
206 jmpbuf
= make_jmpbuf ();
208 scm_dynwinds
= scm_acons (tag
, jmpbuf
, scm_dynwinds
);
209 SETJBJMPBUF(jmpbuf
, &jbr
.buf
);
210 #ifdef DEBUG_EXTENSIONS
211 SCM_SETJBDFRAME(jmpbuf
, scm_last_debug_frame
);
213 if (setjmp (jbr
.buf
))
218 #ifdef STACK_CHECKING
219 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
222 DEACTIVATEJB (jmpbuf
);
223 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
225 throw_args
= jbr
.retval
;
226 throw_tag
= jbr
.throw_tag
;
227 jbr
.throw_tag
= SCM_EOL
;
228 jbr
.retval
= SCM_EOL
;
229 answer
= handler (handler_data
, throw_tag
, throw_args
);
234 answer
= body (body_data
, jmpbuf
);
236 DEACTIVATEJB (jmpbuf
);
237 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
245 /* scm_internal_lazy_catch (the guts of lazy catching) */
247 /* The smob tag for lazy_catch smobs. */
248 static long tc16_lazy_catch
;
250 /* This is the structure we put on the wind list for a lazy catch. It
251 stores the handler function to call, and the data pointer to pass
252 through to it. It's not a Scheme closure, but it is a function
253 with data, so the term "closure" is appropriate in its broader
256 (We don't need anything like this in the "eager" catch code,
257 because the same C frame runs both the body and the handler.) */
259 scm_catch_handler_t handler
;
263 /* Strictly speaking, we could just pass a zero for our print
264 function, because we don't need to print them. They should never
265 appear in normal data structures, only in the wind list. However,
266 it might be nice for debugging someday... */
268 print_lazy_catch (SCM closure
, SCM port
, scm_print_state
*pstate
)
270 struct lazy_catch
*c
= (struct lazy_catch
*) SCM_CDR (closure
);
273 sprintf (buf
, "#<lazy-catch 0x%lx 0x%lx>",
274 (long) c
->handler
, (long) c
->handler_data
);
275 scm_gen_puts (scm_regular_string
, buf
, port
);
280 static scm_smobfuns lazy_catch_funs
= {
281 scm_mark0
, scm_free0
, print_lazy_catch
, 0
285 /* Given a pointer to a lazy catch structure, return a smob for it,
286 suitable for inclusion in the wind list. ("Ah yes, a Château
287 Gollombiere '72, non?"). */
289 make_lazy_catch (struct lazy_catch
*c
)
294 SCM_SETCDR (smob
, c
);
295 SCM_SETCAR (smob
, tc16_lazy_catch
);
300 #define SCM_LAZY_CATCH_P(obj) \
301 (SCM_NIMP (obj) && (SCM_CAR (obj) == tc16_lazy_catch))
304 /* Exactly like scm_internal_catch, except:
305 - It does not unwind the stack (this is the major difference).
306 - If handler returns, its value is returned from the throw.
307 - BODY always receives #f as its JMPBUF argument (since there's no
308 jmpbuf associated with a lazy catch, because we don't unwind the
311 scm_internal_lazy_catch (tag
, body
, body_data
, handler
, handler_data
)
313 scm_catch_body_t body
;
315 scm_catch_handler_t handler
;
318 SCM lazy_catch
, answer
;
322 c
.handler_data
= handler_data
;
323 lazy_catch
= make_lazy_catch (&c
);
326 scm_dynwinds
= scm_acons (tag
, lazy_catch
, scm_dynwinds
);
329 answer
= (*body
) (body_data
, SCM_BOOL_F
);
332 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
340 /* body and handler functions for use with either of the above */
342 /* This is a body function you can pass to scm_internal_catch if you
343 want the body to be like Scheme's `catch' --- a thunk, or a
344 function of one argument if the tag is #f.
346 BODY_DATA is a pointer to a scm_body_thunk_data structure, which
347 contains the Scheme procedure to invoke as the body, and the tag
348 we're catching. If the tag is #f, then we pass JMPBUF (created by
349 scm_internal_catch) to the body procedure; otherwise, the body gets
353 scm_body_thunk (body_data
, jmpbuf
)
357 struct scm_body_thunk_data
*c
= (struct scm_body_thunk_data
*) body_data
;
359 if (c
->tag
== SCM_BOOL_F
)
360 return scm_apply (c
->body_proc
, scm_cons (jmpbuf
, SCM_EOL
), SCM_EOL
);
362 return scm_apply (c
->body_proc
, SCM_EOL
, SCM_EOL
);
366 /* This is a handler function you can pass to scm_internal_catch if
367 you want the handler to act like Scheme's catch --- call a
368 procedure with the tag and the throw arguments.
370 If the user does a throw to this catch, this function runs a
371 handler procedure written in Scheme. HANDLER_DATA is a pointer to
372 an SCM variable holding the Scheme procedure object to invoke. It
373 ought to be a pointer to an automatic variable (i.e., one living on
374 the stack), or the procedure object should be otherwise protected
377 scm_handle_by_proc (handler_data
, tag
, throw_args
)
382 SCM
*handler_proc_p
= (SCM
*) handler_data
;
384 return scm_apply (*handler_proc_p
, scm_cons (tag
, throw_args
), SCM_EOL
);
388 /* This is a handler function to use if you want scheme to print a
389 message and die. Useful for dealing with throws to uncaught keys
392 At boot time, we establish a catch-all that uses this as its handler.
393 1) If the user wants something different, they can use (catch #t
394 ...) to do what they like.
395 2) Outside the context of a read-eval-print loop, there isn't
396 anything else good to do; libguile should not assume the existence
397 of a read-eval-print loop.
398 3) Given that we shouldn't do anything complex, it's much more
399 robust to do it in C code.
401 HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
402 message header to print; if zero, we use "guile" instead. That
403 text is followed by a colon, then the message described by ARGS. */
406 scm_handle_by_message (handler_data
, tag
, args
)
411 char *prog_name
= (char *) handler_data
;
412 SCM p
= scm_def_errp
;
414 if (SCM_NFALSEP (scm_eq_p (tag
, SCM_CAR (scm_intern0 ("quit")))))
415 exit (scm_exit_status (args
));
420 scm_gen_puts (scm_regular_string
, prog_name
, p
);
421 scm_gen_puts (scm_regular_string
, ": ", p
);
423 if (scm_ilength (args
) >= 3)
425 SCM message
= SCM_CADR (args
);
426 SCM parts
= SCM_CADDR (args
);
428 scm_display_error_message (message
, parts
, p
);
432 scm_gen_puts (scm_regular_string
, "uncaught throw to ", p
);
433 scm_prin1 (tag
, p
, 0);
434 scm_gen_puts (scm_regular_string
, ": ", p
);
435 scm_prin1 (args
, p
, 1);
436 scm_gen_putc ('\n', p
);
443 /* Derive the an exit status from the arguments to (quit ...). */
445 scm_exit_status (args
)
448 if (SCM_NNULLP (args
))
450 SCM cqa
= SCM_CAR (args
);
453 return (SCM_INUM (cqa
));
454 else if (SCM_FALSEP (cqa
))
463 /* the Scheme-visible CATCH and LAZY-CATCH functions */
465 SCM_PROC(s_catch
, "catch", 3, 0, 0, scm_catch
);
467 scm_catch (tag
, thunk
, handler
)
472 struct scm_body_thunk_data c
;
474 SCM_ASSERT ((tag
== SCM_BOOL_F
)
475 || (SCM_NIMP(tag
) && SCM_SYMBOLP(tag
))
476 || (tag
== SCM_BOOL_T
),
477 tag
, SCM_ARG1
, s_catch
);
482 /* scm_internal_catch takes care of all the mechanics of setting up
483 a catch tag; we tell it to call scm_body_thunk to run the body,
484 and scm_handle_by_proc to deal with any throws to this catch.
485 The former receives a pointer to c, telling it how to behave.
486 The latter receives a pointer to HANDLER, so it knows who to call. */
487 return scm_internal_catch (tag
,
489 scm_handle_by_proc
, &handler
);
493 SCM_PROC(s_lazy_catch
, "lazy-catch", 3, 0, 0, scm_lazy_catch
);
495 scm_lazy_catch (tag
, thunk
, handler
)
500 struct scm_body_thunk_data c
;
502 SCM_ASSERT ((SCM_NIMP(tag
) && SCM_SYMBOLP(tag
))
503 || (tag
== SCM_BOOL_T
),
504 tag
, SCM_ARG1
, s_lazy_catch
);
509 /* scm_internal_lazy_catch takes care of all the mechanics of
510 setting up a lazy catch tag; we tell it to call scm_body_thunk to
511 run the body, and scm_handle_by_proc to deal with any throws to
512 this catch. The former receives a pointer to c, telling it how
513 to behave. The latter receives a pointer to HANDLER, so it knows
515 return scm_internal_lazy_catch (tag
,
517 scm_handle_by_proc
, &handler
);
524 SCM_PROC(s_throw
, "throw", 1, 0, 1, scm_throw
);
526 scm_throw (key
, args
)
530 /* May return if handled by lazy catch. */
531 return scm_ithrow (key
, args
, 1);
536 scm_ithrow (key
, args
, noreturn
)
544 if (SCM_NIMP (key
) && SCM_JMPBUFP (key
))
549 SCM_ASSERT (JBACTIVE (jmpbuf
), jmpbuf
,
550 "throw to dynamically inactive catch",
553 else if (!JBACTIVE (jmpbuf
))
554 return SCM_UNSPECIFIED
;
558 SCM dynpair
= SCM_UNDEFINED
;
563 SCM_ASSERT (SCM_NIMP (key
) && SCM_SYMBOLP (key
), key
, SCM_ARG1
,
566 else if (!(SCM_NIMP (key
) && SCM_SYMBOLP (key
)))
567 return SCM_UNSPECIFIED
;
569 /* Search the wind list for an appropriate catch.
570 "Waiter, please bring us the wind list." */
571 for (winds
= scm_dynwinds
; SCM_NIMP (winds
); winds
= SCM_CDR (winds
))
573 if (! SCM_CONSP (winds
))
576 dynpair
= SCM_CAR (winds
);
577 if (SCM_NIMP (dynpair
) && SCM_CONSP (dynpair
))
579 SCM this_key
= SCM_CAR (dynpair
);
581 if (this_key
== SCM_BOOL_T
|| this_key
== key
)
586 /* If we didn't find anything, abort. scm_boot_guile should
587 have established a catch-all, but obviously things are
588 thoroughly screwed up. */
589 if (winds
== SCM_EOL
)
592 /* If the wind list is malformed, bail. */
593 if (SCM_IMP (winds
) || SCM_NCONSP (winds
))
596 if (dynpair
!= SCM_BOOL_F
)
597 jmpbuf
= SCM_CDR (dynpair
);
601 return SCM_UNSPECIFIED
;
604 scm_exitval
= scm_cons (key
, args
);
605 scm_dowinds (SCM_EOL
, scm_ilength (scm_dynwinds
));
606 #ifdef DEBUG_EXTENSIONS
607 scm_last_debug_frame
= SCM_DFRAME (scm_rootcont
);
609 longjmp (SCM_JMPBUF (scm_rootcont
), 1);
613 for (wind_goal
= scm_dynwinds
;
614 SCM_CDAR (wind_goal
) != jmpbuf
;
615 wind_goal
= SCM_CDR (wind_goal
))
618 /* Is a lazy catch? In wind list entries for lazy catches, the key
619 is bound to a lazy_catch smob, not a jmpbuf. */
620 if (SCM_LAZY_CATCH_P (jmpbuf
))
622 struct lazy_catch
*c
= (struct lazy_catch
*) SCM_CDR (jmpbuf
);
623 SCM oldwinds
= scm_dynwinds
;
625 scm_dowinds (wind_goal
, (scm_ilength (scm_dynwinds
)
626 - scm_ilength (wind_goal
)));
628 handle
= scm_dynwinds
;
629 scm_dynwinds
= SCM_CDR (scm_dynwinds
);
631 answer
= (c
->handler
) (c
->handler_data
, key
, args
);
633 SCM_SETCDR (handle
, scm_dynwinds
);
634 scm_dynwinds
= handle
;
636 scm_dowinds (oldwinds
, (scm_ilength (scm_dynwinds
)
637 - scm_ilength (oldwinds
)));
641 /* Otherwise, it's a normal catch. */
642 else if (SCM_JMPBUFP (jmpbuf
))
644 struct jmp_buf_and_retval
* jbr
;
645 scm_dowinds (wind_goal
, (scm_ilength (scm_dynwinds
)
646 - scm_ilength (wind_goal
)));
647 jbr
= (struct jmp_buf_and_retval
*)JBJMPBUF (jmpbuf
);
648 jbr
->throw_tag
= key
;
652 /* Otherwise, it's some random piece of junk. */
656 #ifdef DEBUG_EXTENSIONS
657 scm_last_debug_frame
= SCM_JBDFRAME (jmpbuf
);
659 longjmp (*JBJMPBUF (jmpbuf
), 1);
666 scm_tc16_jmpbuffer
= scm_newsmob (&jbsmob
);
667 tc16_lazy_catch
= scm_newsmob (&lazy_catch_funs
);