libguile/throw.c

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