libguile/throw.c

   1 /*      Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  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.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  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.
  36  *
  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.
  40  */
  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 "dynwind.h"
  50 #include "backtrace.h"
  51 #ifdef DEBUG_EXTENSIONS
  52 #include "debug.h"
  53 #endif
  54 #include "continuations.h"
  55 #include "stackchk.h"
  56
  57 #include "throw.h"
  58
  59 \f
  60 /* {Catch and Throw}
  61  */
  62 static int scm_tc16_jmpbuffer;
  63
  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)))
  68
  69 #ifndef DEBUG_EXTENSIONS
  70 #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
  71 #define SETJBJMPBUF SCM_SETCDR
  72 #else
  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)
  77
  78 static scm_sizet freejb SCM_P ((SCM jbsmob));
  79
  80 static scm_sizet
  81 freejb (jbsmob)
  82      SCM jbsmob;
  83 {
  84   scm_must_free ((char *) SCM_CDR (jbsmob));
  85   return sizeof (scm_cell);
  86 }
  87 #endif
  88
  89 static int printjb SCM_P ((SCM exp, SCM port, scm_print_state *pstate));
  90 static int
  91 printjb (exp, port, pstate)
  92      SCM exp;
  93      SCM port;
  94      scm_print_state *pstate;
  95 {
  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);
 100   return 1 ;
 101 }
 102
 103 static scm_smobfuns jbsmob = {
 104   scm_mark0,
 105 #ifdef DEBUG_EXTENSIONS
 106   freejb,
 107 #else
 108   scm_free0,
 109 #endif
 110   printjb,
 111   0
 112 };
 113
 114 static SCM make_jmpbuf SCM_P ((void));
 115 static SCM
 116 make_jmpbuf ()
 117 {
 118   SCM answer;
 119   SCM_NEWCELL (answer);
 120   SCM_REDEFER_INTS;
 121   {
 122 #ifdef DEBUG_EXTENSIONS
 123     char *mem = scm_must_malloc (sizeof (scm_cell), "jb");
 124     SCM_SETCDR (answer, (SCM) mem);
 125 #endif
 126     SCM_SETCAR (answer, scm_tc16_jmpbuffer);
 127     SETJBJMPBUF(answer, (jmp_buf *)0);
 128     DEACTIVATEJB(answer);
 129   }
 130   SCM_REALLOW_INTS;
 131   return answer;
 132 }
 133
 134 struct jmp_buf_and_retval       /* use only on the stack, in scm_catch */
 135 {
 136   jmp_buf buf;                  /* must be first */
 137   SCM throw_tag;
 138   SCM retval;
 139 };
 140
 141
 142 /* scm_internal_catch is the guts of catch.  It handles all the
 143    mechanics of setting up a catch target, invoking the catch body,
 144    and perhaps invoking the handler if the body does a throw.
 145
 146    The function is designed to be usable from C code, but is general
 147    enough to implement all the semantics Guile Scheme expects from
 148    throw.
 149
 150    TAG is the catch tag.  Typically, this is a symbol, but this
 151    function doesn't actually care about that.
 152
 153    BODY is a pointer to a C function which runs the body of the catch;
 154    this is the code you can throw from.  We call it like this:
 155       BODY (DATA, JMPBUF)
 156    where:
 157       DATA is just the DATA argument we received; we pass it through
 158          to BODY as its first argument.  The caller can make DATA point
 159          to anything useful that BODY might need.
 160       JMPBUF is the Scheme jmpbuf object corresponding to this catch,
 161          which we have just created and initialized.
 162
 163    HANDLER is a pointer to a C function to deal with a throw to TAG,
 164    should one occur.  We call it like this:
 165       HANDLER (DATA, TAG, THROW_ARGS)
 166    where
 167       DATA is the DATA argument we recevied, as for BODY above.
 168       TAG is the tag that the user threw to; usually this is TAG, but
 169          it could be something else if TAG was #t (i.e., a catch-all),
 170          or the user threw to a jmpbuf.
 171       THROW_ARGS is the list of arguments the user passed to the THROW
 172          function.
 173
 174    DATA is just a pointer we pass through to BODY and (if we call it)
 175    HANDLER.  We don't actually use it otherwise ourselves.  The idea
 176    is that, if our caller wants to communicate something to BODY and
 177    HANDLER, it can pass a pointer to it as DATA, which BODY and
 178    HANDLER can then use.  Think of it as a way to make BODY and
 179    HANDLER closures, not just functions; DATA points to the enclosed
 180    variables.  */
 181
 182 SCM
 183 scm_internal_catch (tag, body, handler, data)
 184      SCM tag;
 185      scm_catch_body_t body;
 186      scm_catch_handler_t handler;
 187      void *data;
 188 {
 189   struct jmp_buf_and_retval jbr;
 190   SCM jmpbuf;
 191   SCM answer;
 192
 193   jmpbuf = make_jmpbuf ();
 194   answer = SCM_EOL;
 195   scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds);
 196   SETJBJMPBUF(jmpbuf, &jbr.buf);
 197 #ifdef DEBUG_EXTENSIONS
 198   SCM_SETJBDFRAME(jmpbuf, scm_last_debug_frame);
 199 #endif
 200   if (setjmp (jbr.buf))
 201     {
 202       SCM throw_tag;
 203       SCM throw_args;
 204
 205 #ifdef STACK_CHECKING
 206       scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 207 #endif
 208       SCM_REDEFER_INTS;
 209       DEACTIVATEJB (jmpbuf);
 210       scm_dynwinds = SCM_CDR (scm_dynwinds);
 211       SCM_REALLOW_INTS;
 212       throw_args = jbr.retval;
 213       throw_tag = jbr.throw_tag;
 214       jbr.throw_tag = SCM_EOL;
 215       jbr.retval = SCM_EOL;
 216       answer = handler (data, throw_tag, throw_args);
 217     }
 218   else
 219     {
 220       ACTIVATEJB (jmpbuf);
 221       answer = body (data, jmpbuf);
 222       SCM_REDEFER_INTS;
 223       DEACTIVATEJB (jmpbuf);
 224       scm_dynwinds = SCM_CDR (scm_dynwinds);
 225       SCM_REALLOW_INTS;
 226     }
 227   return answer;
 228 }
 229
 230
 231 /* scm_catch passes a pointer to one of these structures through to
 232    its body and handler routines, to tell them what to do.  */
 233 struct catch_body_data
 234 {
 235   /* The tag being caught.  We only use it to figure out what
 236      arguments to pass to the body procedure; see catch_body for
 237      details.  */
 238   SCM tag;
 239
 240   /* The Scheme procedure object constituting the catch body.
 241      catch_body invokes this.  */
 242   SCM body_proc;
 243
 244   /* The Scheme procedure object we invoke to handle throws.  */
 245   SCM handler_proc;
 246 };
 247
 248
 249 /* This function runs the catch body.  DATA contains the Scheme
 250    procedure to invoke.  If the tag being caught is #f, then we pass
 251    JMPBUF to the body procedure; otherwise, it gets no arguments.  */
 252 static SCM catch_body SCM_P ((void *, SCM));
 253
 254 static SCM
 255 catch_body (data, jmpbuf)
 256      void *data;
 257      SCM jmpbuf;
 258 {
 259   struct catch_body_data *c = (struct catch_body_data *) data;
 260
 261   if (c->tag == SCM_BOOL_F)
 262     return scm_apply (c->body_proc, scm_cons (jmpbuf, SCM_EOL), SCM_EOL);
 263   else
 264     return scm_apply (c->body_proc, SCM_EOL, SCM_EOL);
 265 }
 266
 267
 268 /* If the user does a throw to this catch, this function runs the
 269    handler.  DATA says which Scheme procedure object to invoke.  */
 270 static SCM catch_handler SCM_P ((void *, SCM, SCM));
 271
 272 static SCM
 273 catch_handler (data, tag, throw_args)
 274      void *data;
 275      SCM tag;
 276      SCM throw_args;
 277 {
 278   struct catch_body_data *c = (struct catch_body_data *) data;
 279
 280   return scm_apply (c->handler_proc, scm_cons (tag, throw_args), SCM_EOL);
 281 }
 282
 283
 284 SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
 285 SCM
 286 scm_catch (tag, thunk, handler)
 287      SCM tag;
 288      SCM thunk;
 289      SCM handler;
 290 {
 291   struct catch_body_data c;
 292
 293   SCM_ASSERT ((tag == SCM_BOOL_F)
 294               || (SCM_NIMP(tag) && SCM_SYMBOLP(tag))
 295               || (tag == SCM_BOOL_T),
 296               tag, SCM_ARG1, s_catch);
 297
 298   c.tag = tag;
 299   c.body_proc = thunk;
 300   c.handler_proc = handler;
 301
 302   /* scm_internal_catch takes care of all the mechanics of setting up
 303      a catch tag; we tell it to call catch_body to run the body, and
 304      catch_handler to deal with any throws to this catch.  Both those
 305      functions receive the pointer to c, which tells them the details
 306      of how to behave.  */
 307   return scm_internal_catch (tag, catch_body, catch_handler, (void *) &c);
 308 }
 309
 310 SCM_PROC(s_lazy_catch, "lazy-catch", 3, 0, 0, scm_lazy_catch);
 311 SCM
 312 scm_lazy_catch (tag, thunk, handler)
 313      SCM tag;
 314      SCM thunk;
 315      SCM handler;
 316 {
 317   SCM answer;
 318   SCM_ASSERT ((SCM_NIMP(tag) && SCM_SYMBOLP(tag))
 319               || (tag == SCM_BOOL_T),
 320               tag, SCM_ARG1, s_lazy_catch);
 321   SCM_REDEFER_INTS;
 322   scm_dynwinds = scm_acons (tag, handler, scm_dynwinds);
 323   SCM_REALLOW_INTS;
 324   answer = scm_apply (thunk, SCM_EOL, SCM_EOL);
 325   SCM_REDEFER_INTS;
 326   scm_dynwinds = SCM_CDR (scm_dynwinds);
 327   SCM_REALLOW_INTS;
 328   return answer;
 329 }
 330
 331 /* The user has thrown to an uncaught key --- print a message and die.
 332    1) If the user wants something different, they can use (catch #t
 333    ...) to do what they like.
 334    2) Outside the context of a read-eval-print loop, there isn't
 335    anything else good to do; libguile should not assume the existence
 336    of a read-eval-print loop.
 337    3) Given that we shouldn't do anything complex, it's much more
 338    robust to do it in C code.  */
 339 static SCM uncaught_throw SCM_P ((SCM key, SCM args));
 340 static SCM
 341 uncaught_throw (key, args)
 342      SCM key;
 343      SCM args;
 344 {
 345   SCM p = scm_def_errp;
 346
 347   if (scm_ilength (args) >= 3)
 348     {
 349       SCM message = SCM_CADR (args);
 350       SCM parts = SCM_CADDR (args);
 351
 352       scm_gen_puts (scm_regular_string, "guile: ", p);
 353       scm_display_error_message (message, parts, p);
 354     }
 355   else
 356     {
 357       scm_gen_puts (scm_regular_string, "guile: uncaught throw to ", p);
 358       scm_prin1 (key, p, 0);
 359       scm_gen_puts (scm_regular_string, ": ", p);
 360       scm_prin1 (args, p, 1);
 361       scm_gen_putc ('\n', p);
 362     }
 363
 364   exit (2);
 365 }
 366
 367
 368 static char s_throw[];
 369 SCM
 370 scm_ithrow (key, args, noreturn)
 371      SCM key;
 372      SCM args;
 373      int noreturn;
 374 {
 375   SCM jmpbuf;
 376   SCM wind_goal;
 377
 378   if (SCM_NIMP (key) && SCM_JMPBUFP (key))
 379     {
 380       jmpbuf = key;
 381       if (noreturn)
 382         {
 383           SCM_ASSERT (JBACTIVE (jmpbuf), jmpbuf,
 384                   "throw to dynamically inactive catch",
 385                   s_throw);
 386         }
 387       else if (!JBACTIVE (jmpbuf))
 388         return SCM_UNSPECIFIED;
 389     }
 390   else
 391     {
 392       SCM dynpair = SCM_UNDEFINED;
 393       SCM winds;
 394
 395       if (noreturn)
 396         {
 397           SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1,
 398                       s_throw);
 399         }
 400       else if (!(SCM_NIMP (key) && SCM_SYMBOLP (key)))
 401         return SCM_UNSPECIFIED;
 402
 403       /* Search the wind list for an appropriate catch.
 404          "Waiter, please bring us the wind list." */
 405       for (winds = scm_dynwinds; SCM_NIMP (winds); winds = SCM_CDR (winds))
 406         {
 407           if (! SCM_CONSP (winds))
 408             abort ();
 409
 410           dynpair = SCM_CAR (winds);
 411           if (SCM_NIMP (dynpair) && SCM_CONSP (dynpair))
 412             {
 413               SCM this_key = SCM_CAR (dynpair);
 414
 415               if (this_key == SCM_BOOL_T || this_key == key)
 416                 break;
 417             }
 418         }
 419
 420       /* If we didn't find anything, print a message and exit Guile.  */
 421       if (winds == SCM_EOL)
 422         uncaught_throw (key, args);
 423
 424       if (SCM_IMP (winds) || SCM_NCONSP (winds))
 425         abort ();
 426
 427       if (dynpair != SCM_BOOL_F)
 428         jmpbuf = SCM_CDR (dynpair);
 429       else
 430         {
 431           if (!noreturn)
 432             return SCM_UNSPECIFIED;
 433           else
 434             {
 435               scm_exitval = scm_cons (key, args);
 436               scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
 437 #ifdef DEBUG_EXTENSIONS
 438               scm_last_debug_frame = SCM_DFRAME (scm_rootcont);
 439 #endif
 440               longjmp (SCM_JMPBUF (scm_rootcont), 1);
 441             }
 442         }
 443     }
 444   for (wind_goal = scm_dynwinds;
 445        SCM_CDAR (wind_goal) != jmpbuf;
 446        wind_goal = SCM_CDR (wind_goal))
 447     ;
 448   if (!SCM_JMPBUFP (jmpbuf))
 449     {
 450       SCM oldwinds = scm_dynwinds;
 451       SCM handle, answer;
 452       scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal));
 453       SCM_REDEFER_INTS;
 454       handle = scm_dynwinds;
 455       scm_dynwinds = SCM_CDR (scm_dynwinds);
 456       SCM_REALLOW_INTS;
 457       answer = scm_apply (jmpbuf, scm_cons (key, args), SCM_EOL);
 458       SCM_REDEFER_INTS;
 459       SCM_SETCDR (handle, scm_dynwinds);
 460       scm_dynwinds = handle;
 461       SCM_REALLOW_INTS;
 462       scm_dowinds (oldwinds, scm_ilength (scm_dynwinds) - scm_ilength (oldwinds));
 463       return answer;
 464     }
 465   else
 466     {
 467       struct jmp_buf_and_retval * jbr;
 468       scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal));
 469       jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
 470       jbr->throw_tag = key;
 471       jbr->retval = args;
 472     }
 473 #ifdef DEBUG_EXTENSIONS
 474   scm_last_debug_frame = SCM_JBDFRAME (jmpbuf);
 475 #endif
 476   longjmp (*JBJMPBUF (jmpbuf), 1);
 477 }
 478
 479
 480 SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw);
 481 SCM
 482 scm_throw (key, args)
 483      SCM key;
 484      SCM args;
 485 {
 486   /* May return if handled by lazy catch. */
 487   return scm_ithrow (key, args, 1);
 488 }
 489
 490
 491 void
 492 scm_init_throw ()
 493 {
 494   scm_tc16_jmpbuffer = scm_newsmob (&jbsmob);
 495 #include "throw.x"
 496 }