libguile/throw.c

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