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