libguile/throw.c

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