libguile/throw.c

   1 /* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19
  20 \f
  21 #ifdef HAVE_CONFIG_H
  22 # include <config.h>
  23 #endif
  24
  25 #include <stdio.h>
  26 #include <unistdio.h>
  27 #include "libguile/_scm.h"
  28 #include "libguile/smob.h"
  29 #include "libguile/eval.h"
  30 #include "libguile/eq.h"
  31 #include "libguile/control.h"
  32 #include "libguile/deprecation.h"
  33 #include "libguile/backtrace.h"
  34 #include "libguile/debug.h"
  35 #include "libguile/stackchk.h"
  36 #include "libguile/stacks.h"
  37 #include "libguile/fluids.h"
  38 #include "libguile/ports.h"
  39 #include "libguile/lang.h"
  40 #include "libguile/validate.h"
  41 #include "libguile/vm.h"
  42 #include "libguile/throw.h"
  43 #include "libguile/init.h"
  44 #include "libguile/strings.h"
  45
  46 #include "libguile/private-options.h"
  47
  48
  49 /* Pleasantly enough, the guts of catch are defined in Scheme, in terms of
  50    prompt, abort, and the %exception-handler fluid. This file just provides
  51    shims so that it's easy to have catch functionality from C.
  52
  53    All of these function names and prototypes carry a fair bit of historical
  54    baggage. */
  55
  56
  57 #define CACHE_VAR(var,name)                                             \
  58   static SCM var = SCM_BOOL_F;                                          \
  59   if (scm_is_false (var))                                               \
  60     {                                                                   \
  61       var = scm_module_variable (scm_the_root_module (),                \
  62                                  scm_from_locale_symbol (name));        \
  63       if (scm_is_false (var))                                           \
  64         abort ();                                                       \
  65     }
  66
  67 \f
  68
  69 SCM
  70 scm_catch (SCM key, SCM thunk, SCM handler)
  71 {
  72   CACHE_VAR (var, "catch");
  73
  74   return scm_call_3 (scm_variable_ref (var), key, thunk, handler);
  75 }
  76
  77 SCM
  78 scm_catch_with_pre_unwind_handler (SCM key, SCM thunk, SCM handler,
  79                                    SCM pre_unwind_handler)
  80 {
  81   if (SCM_UNBNDP (pre_unwind_handler))
  82     return scm_catch (key, thunk, handler);
  83   else
  84     {
  85       CACHE_VAR (var, "catch");
  86
  87       return scm_call_4 (scm_variable_ref (var), key, thunk, handler,
  88                          pre_unwind_handler);
  89     }
  90 }
  91
  92 SCM
  93 scm_with_throw_handler (SCM key, SCM thunk, SCM handler)
  94 {
  95   CACHE_VAR (var, "with-throw-handler");
  96
  97   return scm_call_3 (scm_variable_ref (var), key, thunk, handler);
  98 }
  99
 100 SCM
 101 scm_throw (SCM key, SCM args)
 102 {
 103   CACHE_VAR (var, "throw");
 104
 105   return scm_apply_1 (scm_variable_ref (var), key, args);
 106 }
 107
 108 \f
 109
 110 /* Now some support for C bodies and catch handlers */
 111
 112 static scm_t_bits tc16_catch_closure;
 113
 114 enum {
 115   CATCH_CLOSURE_BODY,
 116   CATCH_CLOSURE_HANDLER
 117 };
 118
 119 static SCM
 120 make_catch_body_closure (scm_t_catch_body body, void *body_data)
 121 {
 122   SCM ret;
 123   SCM_NEWSMOB2 (ret, tc16_catch_closure, body, body_data);
 124   SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_BODY);
 125   return ret;
 126 }
 127
 128 static SCM
 129 make_catch_handler_closure (scm_t_catch_handler handler, void *handler_data)
 130 {
 131   SCM ret;
 132   SCM_NEWSMOB2 (ret, tc16_catch_closure, handler, handler_data);
 133   SCM_SET_SMOB_FLAGS (ret, CATCH_CLOSURE_HANDLER);
 134   return ret;
 135 }
 136
 137 static SCM
 138 apply_catch_closure (SCM clo, SCM args)
 139 {
 140   void *data = (void*)SCM_SMOB_DATA_2 (clo);
 141
 142   switch (SCM_SMOB_FLAGS (clo))
 143     {
 144     case CATCH_CLOSURE_BODY:
 145       {
 146         scm_t_catch_body body = (void*)SCM_SMOB_DATA (clo);
 147         return body (data);
 148       }
 149     case CATCH_CLOSURE_HANDLER:
 150       {
 151         scm_t_catch_handler handler = (void*)SCM_SMOB_DATA (clo);
 152         return handler (data, scm_car (args), scm_cdr (args));
 153       }
 154     default:
 155       abort ();
 156     }
 157 }
 158
 159 /* TAG is the catch tag.  Typically, this is a symbol, but this
 160    function doesn't actually care about that.
 161
 162    BODY is a pointer to a C function which runs the body of the catch;
 163    this is the code you can throw from.  We call it like this:
 164       BODY (BODY_DATA)
 165    where:
 166       BODY_DATA is just the BODY_DATA argument we received; we pass it
 167          through to BODY as its first argument.  The caller can make
 168          BODY_DATA point to anything useful that BODY might need.
 169
 170    HANDLER is a pointer to a C function to deal with a throw to TAG,
 171    should one occur.  We call it like this:
 172       HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
 173    where
 174       HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
 175          same idea as BODY_DATA above.
 176       THROWN_TAG is the tag that the user threw to; usually this is
 177          TAG, but it could be something else if TAG was #t (i.e., a
 178          catch-all), or the user threw to a jmpbuf.
 179       THROW_ARGS is the list of arguments the user passed to the THROW
 180          function, after the tag.
 181
 182    BODY_DATA is just a pointer we pass through to BODY.  HANDLER_DATA
 183    is just a pointer we pass through to HANDLER.  We don't actually
 184    use either of those pointers otherwise ourselves.  The idea is
 185    that, if our caller wants to communicate something to BODY or
 186    HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
 187    HANDLER can then use.  Think of it as a way to make BODY and
 188    HANDLER closures, not just functions; MUMBLE_DATA points to the
 189    enclosed variables.
 190
 191    Of course, it's up to the caller to make sure that any data a
 192    MUMBLE_DATA needs is protected from GC.  A common way to do this is
 193    to make MUMBLE_DATA a pointer to data stored in an automatic
 194    structure variable; since the collector must scan the stack for
 195    references anyway, this assures that any references in MUMBLE_DATA
 196    will be found.  */
 197
 198 SCM
 199 scm_c_catch (SCM tag,
 200              scm_t_catch_body body, void *body_data,
 201              scm_t_catch_handler handler, void *handler_data,
 202              scm_t_catch_handler pre_unwind_handler, void *pre_unwind_handler_data)
 203 {
 204   SCM sbody, shandler, spre_unwind_handler;
 205
 206   sbody = make_catch_body_closure (body, body_data);
 207   shandler = make_catch_handler_closure (handler, handler_data);
 208   if (pre_unwind_handler)
 209     spre_unwind_handler = make_catch_handler_closure (pre_unwind_handler,
 210                                                       pre_unwind_handler_data);
 211   else
 212     spre_unwind_handler = SCM_UNDEFINED;
 213
 214   return scm_catch_with_pre_unwind_handler (tag, sbody, shandler,
 215                                             spre_unwind_handler);
 216 }
 217
 218 SCM
 219 scm_internal_catch (SCM tag,
 220                     scm_t_catch_body body, void *body_data,
 221                     scm_t_catch_handler handler, void *handler_data)
 222 {
 223   return scm_c_catch (tag,
 224                       body, body_data,
 225                       handler, handler_data,
 226                       NULL, NULL);
 227 }
 228
 229
 230 SCM
 231 scm_c_with_throw_handler (SCM tag,
 232                           scm_t_catch_body body,
 233                           void *body_data,
 234                           scm_t_catch_handler handler,
 235                           void *handler_data,
 236                           int lazy_catch_p)
 237 {
 238   SCM sbody, shandler;
 239
 240   if (lazy_catch_p)
 241     scm_c_issue_deprecation_warning
 242       ("The LAZY_CATCH_P argument to `scm_c_with_throw_handler' is no longer.\n"
 243        "supported. Instead the handler will be invoked from within the dynamic\n"
 244        "context of the corresponding `throw'.\n"
 245        "\nTHIS COULD CHANGE YOUR PROGRAM'S BEHAVIOR.\n\n"
 246        "Please modify your program to pass 0 as the LAZY_CATCH_P argument,\n"
 247        "and adapt it (if necessary) to expect to be within the dynamic context\n"
 248        "of the throw.");
 249
 250   sbody = make_catch_body_closure (body, body_data);
 251   shandler = make_catch_handler_closure (handler, handler_data);
 252
 253   return scm_with_throw_handler (tag, sbody, shandler);
 254 }
 255
 256 \f
 257 /* scm_internal_stack_catch
 258    Use this one if you want debugging information to be stored in
 259    scm_the_last_stack_fluid_var on error. */
 260
 261 static SCM
 262 ss_handler (void *data SCM_UNUSED, SCM tag, SCM throw_args)
 263 {
 264   /* Save the stack */
 265   scm_fluid_set_x (SCM_VARIABLE_REF (scm_the_last_stack_fluid_var),
 266                    scm_make_stack (SCM_BOOL_T, SCM_EOL));
 267   /* Throw the error */
 268   return scm_throw (tag, throw_args);
 269 }
 270
 271 struct cwss_data
 272 {
 273   SCM tag;
 274   scm_t_catch_body body;
 275   void *data;
 276 };
 277
 278 static SCM
 279 cwss_body (void *data)
 280 {
 281   struct cwss_data *d = data;
 282   return scm_c_with_throw_handler (d->tag, d->body, d->data, ss_handler, NULL, 0);
 283 }
 284
 285 SCM
 286 scm_internal_stack_catch (SCM tag,
 287                           scm_t_catch_body body,
 288                           void *body_data,
 289                           scm_t_catch_handler handler,
 290                           void *handler_data)
 291 {
 292   struct cwss_data d;
 293   d.tag = tag;
 294   d.body = body;
 295   d.data = body_data;
 296   return scm_internal_catch (tag, cwss_body, &d, handler, handler_data);
 297 }
 298
 299
 300 \f
 301 /* body and handler functions for use with any of the above catch variants */
 302
 303 /* This is a body function you can pass to scm_internal_catch if you
 304    want the body to be like Scheme's `catch' --- a thunk.
 305
 306    BODY_DATA is a pointer to a scm_body_thunk_data structure, which
 307    contains the Scheme procedure to invoke as the body, and the tag
 308    we're catching.  */
 309
 310 SCM
 311 scm_body_thunk (void *body_data)
 312 {
 313   struct scm_body_thunk_data *c = (struct scm_body_thunk_data *) body_data;
 314
 315   return scm_call_0 (c->body_proc);
 316 }
 317
 318
 319 /* This is a handler function you can pass to scm_internal_catch if
 320    you want the handler to act like Scheme's catch: (throw TAG ARGS ...)
 321    applies a handler procedure to (TAG ARGS ...).
 322
 323    If the user does a throw to this catch, this function runs a
 324    handler procedure written in Scheme.  HANDLER_DATA is a pointer to
 325    an SCM variable holding the Scheme procedure object to invoke.  It
 326    ought to be a pointer to an automatic variable (i.e., one living on
 327    the stack), or the procedure object should be otherwise protected
 328    from GC.  */
 329 SCM
 330 scm_handle_by_proc (void *handler_data, SCM tag, SCM throw_args)
 331 {
 332   SCM *handler_proc_p = (SCM *) handler_data;
 333
 334   return scm_apply_1 (*handler_proc_p, tag, throw_args);
 335 }
 336
 337 /* SCM_HANDLE_BY_PROC_CATCHING_ALL is like SCM_HANDLE_BY_PROC but
 338    catches all throws that the handler might emit itself.  The handler
 339    used for these `secondary' throws is SCM_HANDLE_BY_MESSAGE_NO_EXIT.  */
 340
 341 struct hbpca_data {
 342   SCM proc;
 343   SCM args;
 344 };
 345
 346 static SCM
 347 hbpca_body (void *body_data)
 348 {
 349   struct hbpca_data *data = (struct hbpca_data *)body_data;
 350   return scm_apply_0 (data->proc, data->args);
 351 }
 352
 353 SCM
 354 scm_handle_by_proc_catching_all (void *handler_data, SCM tag, SCM throw_args)
 355 {
 356   SCM *handler_proc_p = (SCM *) handler_data;
 357   struct hbpca_data data;
 358   data.proc = *handler_proc_p;
 359   data.args = scm_cons (tag, throw_args);
 360
 361   return scm_internal_catch (SCM_BOOL_T,
 362                              hbpca_body, &data,
 363                              scm_handle_by_message_noexit, NULL);
 364 }
 365
 366 /* Derive the an exit status from the arguments to (quit ...).  */
 367 int
 368 scm_exit_status (SCM args)
 369 {
 370   if (!SCM_NULL_OR_NIL_P (args))
 371     {
 372       SCM cqa = SCM_CAR (args);
 373
 374       if (scm_is_integer (cqa))
 375         return (scm_to_int (cqa));
 376       else if (scm_is_false (cqa))
 377         return 1;
 378     }
 379   return 0;
 380 }
 381
 382
 383 static void
 384 handler_message (void *handler_data, SCM tag, SCM args)
 385 {
 386   char *prog_name = (char *) handler_data;
 387   SCM p = scm_current_error_port ();
 388
 389   if (scm_ilength (args) == 4)
 390     {
 391       SCM stack   = scm_make_stack (SCM_BOOL_T, SCM_EOL);
 392       SCM subr    = SCM_CAR (args);
 393       SCM message = SCM_CADR (args);
 394       SCM parts   = SCM_CADDR (args);
 395       SCM rest    = SCM_CADDDR (args);
 396
 397       if (SCM_BACKTRACE_P && scm_is_true (stack))
 398         {
 399           SCM highlights;
 400
 401           if (scm_is_eq (tag, scm_arg_type_key)
 402               || scm_is_eq (tag, scm_out_of_range_key))
 403             highlights = rest;
 404           else
 405             highlights = SCM_EOL;
 406
 407           scm_puts ("Backtrace:\n", p);
 408           scm_display_backtrace_with_highlights (stack, p,
 409                                                  SCM_BOOL_F, SCM_BOOL_F,
 410                                                  highlights);
 411           scm_newline (p);
 412         }
 413       scm_i_display_error (stack, p, subr, message, parts, rest);
 414     }
 415   else
 416     {
 417       if (! prog_name)
 418         prog_name = "guile";
 419
 420       scm_puts (prog_name, p);
 421       scm_puts (": ", p);
 422
 423       scm_puts ("uncaught throw to ", p);
 424       scm_prin1 (tag, p, 0);
 425       scm_puts (": ", p);
 426       scm_prin1 (args, p, 1);
 427       scm_putc ('\n', p);
 428     }
 429 }
 430
 431
 432 /* This is a handler function to use if you want scheme to print a
 433    message and die.  Useful for dealing with throws to uncaught keys
 434    at the top level.
 435
 436    At boot time, we establish a catch-all that uses this as its handler.
 437    1) If the user wants something different, they can use (catch #t
 438    ...) to do what they like.
 439    2) Outside the context of a read-eval-print loop, there isn't
 440    anything else good to do; libguile should not assume the existence
 441    of a read-eval-print loop.
 442    3) Given that we shouldn't do anything complex, it's much more
 443    robust to do it in C code.
 444
 445    HANDLER_DATA, if non-zero, is assumed to be a char * pointing to a
 446    message header to print; if zero, we use "guile" instead.  That
 447    text is followed by a colon, then the message described by ARGS.  */
 448
 449 /* Dirk:FIXME:: The name of the function should make clear that the
 450  * application gets terminated.
 451  */
 452
 453 SCM
 454 scm_handle_by_message (void *handler_data, SCM tag, SCM args)
 455 {
 456   if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
 457     exit (scm_exit_status (args));
 458
 459   handler_message (handler_data, tag, args);
 460   scm_i_pthread_exit (NULL);
 461
 462   /* this point not reached, but suppress gcc warning about no return value
 463      in case scm_i_pthread_exit isn't marked as "noreturn" (which seemed not
 464      to be the case on cygwin for instance) */
 465   return SCM_BOOL_F;
 466 }
 467
 468
 469 /* This is just like scm_handle_by_message, but it doesn't exit; it
 470    just returns #f.  It's useful in cases where you don't really know
 471    enough about the body to handle things in a better way, but don't
 472    want to let throws fall off the bottom of the wind list.  */
 473 SCM
 474 scm_handle_by_message_noexit (void *handler_data, SCM tag, SCM args)
 475 {
 476   if (scm_is_true (scm_eq_p (tag, scm_from_locale_symbol ("quit"))))
 477     exit (scm_exit_status (args));
 478
 479   handler_message (handler_data, tag, args);
 480
 481   return SCM_BOOL_F;
 482 }
 483
 484
 485 SCM
 486 scm_handle_by_throw (void *handler_data SCM_UNUSED, SCM tag, SCM args)
 487 {
 488   scm_ithrow (tag, args, 1);
 489   return SCM_UNSPECIFIED;  /* never returns */
 490 }
 491
 492 SCM
 493 scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED)
 494 {
 495   return scm_throw (key, args);
 496 }
 497
 498 /* Unfortunately we have to support catch and throw before boot-9 has, um,
 499    booted. So here are lame versions, which will get replaced with their scheme
 500    equivalents. */
 501 static SCM
 502 pre_init_catch (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler)
 503 {
 504   SCM vm, prompt, res;
 505
 506   /* Only handle catch-alls without pre-unwind handlers */
 507   if (!SCM_UNBNDP (pre_unwind_handler))
 508     abort ();
 509   if (scm_is_false (scm_eqv_p (tag, SCM_BOOL_T)))
 510     abort ();
 511
 512   vm = scm_the_vm ();
 513   prompt = scm_c_make_prompt (scm_fluid_ref (scm_sys_default_prompt_tag),
 514                               SCM_VM_DATA (vm)->fp, SCM_VM_DATA (vm)->sp,
 515                               SCM_VM_DATA (vm)->ip, 1, -1, scm_i_dynwinds ());
 516   scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt)));
 517
 518   if (SCM_PROMPT_SETJMP (prompt))
 519     {
 520       /* nonlocal exit */
 521       SCM args = scm_i_prompt_pop_abort_args_x (prompt);
 522       /* cdr past the continuation */
 523       return scm_apply_0 (handler, scm_cdr (args));
 524     }
 525
 526   res = scm_call_0 (thunk);
 527   scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ()));
 528
 529   return res;
 530 }
 531
 532 static SCM
 533 pre_init_throw (SCM args)
 534 {
 535   return scm_at_abort (scm_fluid_ref (scm_sys_default_prompt_tag), args);
 536 }
 537
 538 void
 539 scm_init_throw ()
 540 {
 541   tc16_catch_closure = scm_make_smob_type ("catch-closure", 0);
 542   scm_set_smob_apply (tc16_catch_closure, apply_catch_closure, 0, 0, 1);
 543
 544   scm_c_define ("catch", scm_c_make_gsubr ("catch", 3, 1, 0, pre_init_catch));
 545   scm_c_define ("throw", scm_c_make_gsubr ("throw", 0, 0, 1, pre_init_throw));
 546
 547 #include "libguile/throw.x"
 548 }
 549
 550 /*
 551   Local Variables:
 552   c-file-style: "gnu"
 553   End:
 554 */