Merge commit 'feccd2d3100fd2964d4c2df58ab3da7ce4949a66' into vm-check

[bpt/guile.git] / libguile / throw.c

/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
 * 
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */


\f
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <stdio.h>
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/smob.h"
#include "libguile/alist.h"
#include "libguile/eval.h"
#include "libguile/eq.h"
#include "libguile/dynwind.h"
#include "libguile/backtrace.h"
#include "libguile/debug.h"
#include "libguile/continuations.h"
#include "libguile/stackchk.h"
#include "libguile/stacks.h"
#include "libguile/fluids.h"
#include "libguile/ports.h"
#include "libguile/lang.h"
#include "libguile/validate.h"
#include "libguile/throw.h"
#include "libguile/init.h"
#include "libguile/strings.h"
#include "libguile/vm.h"

#include "libguile/private-options.h"


\f
/* the jump buffer data structure */
static scm_t_bits tc16_jmpbuffer;

#define SCM_JMPBUFP(OBJ)	SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)

#define JBACTIVE(OBJ)		(SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
#define ACTIVATEJB(x)	\
  (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L))))
#define DEACTIVATEJB(x) \
  (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L))))

#define JBJMPBUF(OBJ)           ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
#define SETJBJMPBUF(x, v)        (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v)))
#define SCM_JBDFRAME(x)         ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x))
#define SCM_SETJBDFRAME(x, v)    (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v)))
#define SCM_JBPREUNWIND(x)      ((struct pre_unwind_data *) SCM_CELL_WORD_3 (x))
#define SCM_SETJBPREUNWIND(x, v) (SCM_SET_CELL_WORD_3 ((x), (scm_t_bits) (v)))

static int
jmpbuffer_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  scm_puts ("#<jmpbuffer ", port);
  scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
  scm_uintprint((scm_t_bits) JBJMPBUF (exp), 16, port);
  scm_putc ('>', port);
  return 1 ;
}

static SCM
make_jmpbuf (void)
{
  SCM answer;
  SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0);
  SETJBJMPBUF(answer, (jmp_buf *)0);
  DEACTIVATEJB(answer);
  return answer;
}

\f
/* scm_c_catch (the guts of catch) */

struct jmp_buf_and_retval	/* use only on the stack, in scm_catch */
{
  jmp_buf buf;			/* must be first */
  SCM throw_tag;
  SCM retval;
};

/* These are the structures we use to store pre-unwind handling (aka
   "lazy") information for a regular catch, and put on the wind list
   for a "lazy" catch.  They store the pre-unwind handler function to
   call, and the data pointer to pass through to it.  It's not a
   Scheme closure, but it is a function with data, so the term
   "closure" is appropriate in its broader sense.

   (We don't need anything like this to run the normal (post-unwind)
   catch handler, because the same C frame runs both the body and the
   handler.)  */

struct pre_unwind_data {
  scm_t_catch_handler handler;
  void *handler_data;
  int running;
  int lazy_catch_p;
};


/* scm_c_catch is the guts of catch.  It handles all the mechanics of
   setting up a catch target, invoking the catch body, and perhaps
   invoking the handler if the body does a throw.

   The function is designed to be usable from C code, but is general
   enough to implement all the semantics Guile Scheme expects from
   throw.

   TAG is the catch tag.  Typically, this is a symbol, but this
   function doesn't actually care about that.

   BODY is a pointer to a C function which runs the body of the catch;
   this is the code you can throw from.  We call it like this:
      BODY (BODY_DATA)
   where:
      BODY_DATA is just the BODY_DATA argument we received; we pass it
	 through to BODY as its first argument.  The caller can make
	 BODY_DATA point to anything useful that BODY might need.

   HANDLER is a pointer to a C function to deal with a throw to TAG,
   should one occur.  We call it like this:
      HANDLER (HANDLER_DATA, THROWN_TAG, THROW_ARGS)
   where
      HANDLER_DATA is the HANDLER_DATA argument we recevied; it's the
         same idea as BODY_DATA above.
      THROWN_TAG is the tag that the user threw to; usually this is
         TAG, but it could be something else if TAG was #t (i.e., a
         catch-all), or the user threw to a jmpbuf.
      THROW_ARGS is the list of arguments the user passed to the THROW
         function, after the tag.

   BODY_DATA is just a pointer we pass through to BODY.  HANDLER_DATA
   is just a pointer we pass through to HANDLER.  We don't actually
   use either of those pointers otherwise ourselves.  The idea is
   that, if our caller wants to communicate something to BODY or
   HANDLER, it can pass a pointer to it as MUMBLE_DATA, which BODY and
   HANDLER can then use.  Think of it as a way to make BODY and
   HANDLER closures, not just functions; MUMBLE_DATA points to the
   enclosed variables.

   Of course, it's up to the caller to make sure that any data a
   MUMBLE_DATA needs is protected from GC.  A common way to do this is
   to make MUMBLE_DATA a pointer to data stored in an automatic
   structure variable; since the collector must scan the stack for
   references anyway, this assures that any references in MUMBLE_DATA
   will be found.  */

SCM
scm_c_catch (SCM tag,
	     scm_t_catch_body body, void *body_data,
	     scm_t_catch_handler handler, void *handler_data,
	     scm_t_catch_handler pre_unwind_handler, void *pre_unwind_handler_data)
{
  struct jmp_buf_and_retval jbr;
  SCM jmpbuf;
  SCM answer;
  SCM vm;
  SCM *sp = NULL, *fp = NULL; /* to reset the vm */
  struct pre_unwind_data pre_unwind;

  vm = scm_the_vm ();
  if (SCM_NFALSEP (vm))
    {
      sp = SCM_VM_DATA (vm)->sp;
      fp = SCM_VM_DATA (vm)->fp;
    }

  jmpbuf = make_jmpbuf ();
  answer = SCM_EOL;
  scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ()));
  SETJBJMPBUF(jmpbuf, &jbr.buf);
  SCM_SETJBDFRAME(jmpbuf, scm_i_last_debug_frame ());

  pre_unwind.handler = pre_unwind_handler;
  pre_unwind.handler_data = pre_unwind_handler_data;
  pre_unwind.running = 0;
  pre_unwind.lazy_catch_p = 0;
  SCM_SETJBPREUNWIND(jmpbuf, &pre_unwind);

  if (setjmp (jbr.buf))
    {
      SCM throw_tag;
      SCM throw_args;

#ifdef STACK_CHECKING
      scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
#endif
      SCM_CRITICAL_SECTION_START;
      DEACTIVATEJB (jmpbuf);
      scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
      SCM_CRITICAL_SECTION_END;
      throw_args = jbr.retval;
      throw_tag = jbr.throw_tag;
      jbr.throw_tag = SCM_EOL;
      jbr.retval = SCM_EOL;
      if (SCM_NFALSEP (vm))
        {
          SCM_VM_DATA (vm)->sp = sp;
          SCM_VM_DATA (vm)->fp = fp;
#ifdef VM_ENABLE_STACK_NULLING
          /* see vm.c -- you'll have to enable this manually */
          memset (sp + 1, 0,
                  (SCM_VM_DATA (vm)->stack_size
                   - (sp + 1 - SCM_VM_DATA (vm)->stack_base)) * sizeof(SCM));
#endif
        }
      else if (SCM_NFALSEP ((vm = scm_the_vm ())))
        {
          /* oof, it's possible this catch was called before the vm was
             booted... yick. anyway, try to reset the vm stack. */
          SCM_VM_DATA (vm)->sp = SCM_VM_DATA (vm)->stack_base - 1;
          SCM_VM_DATA (vm)->fp = NULL;
#ifdef VM_ENABLE_STACK_NULLING
          /* see vm.c -- you'll have to enable this manually */
          memset (SCM_VM_DATA (vm)->stack_base, 0,
                  SCM_VM_DATA (vm)->stack_size * sizeof(SCM));
#endif
        }
          
      answer = handler (handler_data, throw_tag, throw_args);
    }
  else
    {
      ACTIVATEJB (jmpbuf);
      answer = body (body_data);
      SCM_CRITICAL_SECTION_START;
      DEACTIVATEJB (jmpbuf);
      scm_i_set_dynwinds (SCM_CDR (scm_i_dynwinds ()));
      SCM_CRITICAL_SECTION_END;
    }
  return answer;
}

SCM
scm_internal_catch (SCM tag,
		    scm_t_catch_body body, void *body_data,
		    scm_t_catch_handler handler, void *handler_data)
{
  return scm_c_catch(tag,
		     body, body_data,
		     handler, handler_data,
		     NULL, NULL);
}


\f
/* The smob tag for pre_unwind_data smobs.  */
static scm_t_bits tc16_pre_unwind_data;

/* Strictly speaking, we could just pass a zero for our print
   function, because we don't need to print them.  They should never
   appear in normal data structures, only in the wind list.  However,
   it might be nice for debugging someday... */
static int
pre_unwind_data_print (SCM closure, SCM port, scm_print_state *pstate SCM_UNUSED)
{
  struct pre_unwind_data *c = (struct pre_unwind_data *) SCM_CELL_WORD_1 (closure);
  char buf[200];

  sprintf (buf, "#<pre-unwind-data 0x%lx 0x%lx>",
	   (long) c->handler, (long) c->handler_data);
  scm_puts (buf, port);

  return 1;
}


/* Given a pointer to a pre_unwind_data structure, return a smob for it,