libguile/throw.c

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