comparison src/eval.c @ 109353:d43e7dfda4f1

merge trunk

109352:2803d726899d

/* Evaluator for GNU Emacs Lisp interpreter.
   Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1999, 2000, 2001,
                 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
                 Free Software Foundation, Inc.

This file is part of GNU Emacs.

GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by

extern Lisp_Object Qfunction;

static Lisp_Object funcall_lambda (Lisp_Object, int, Lisp_Object*);
static void unwind_to_catch (struct catchtag *, Lisp_Object) NO_RETURN;

#if __GNUC__
/* "gcc -O3" enables automatic function inlining, which optimizes out
   the arguments for the invocations of these functions, whereas they
   expect these values on the stack.  */
Lisp_Object apply1 (Lisp_Object fn, Lisp_Object arg) __attribute__((noinline));
Lisp_Object call2 (Lisp_Object fn, Lisp_Object arg1, Lisp_Object arg2) __attribute__((noinline));
#endif

void
init_eval_once (void)
{
  specpdl_size = 50;

  GCPRO2 (args, val);

  do
    {
      if (!(argnum++))
        val = Feval (Fcar (args_left));
      else
	Feval (Fcar (args_left));
      args_left = Fcdr (args_left);
    }
  while (!NILP(args_left));

  GCPRO2 (args, val);

  do
    {
      if (!(argnum++))
        val = Feval (Fcar (args_left));
      else
	Feval (Fcar (args_left));
      args_left = Fcdr (args_left);
    }
  while (!NILP (args_left));

      return Qnil;

  /* If indirect and there's an alias loop, don't check anything else.  */
  if (XSYMBOL (variable)->redirect == SYMBOL_VARALIAS
      && NILP (internal_condition_case_1 (lisp_indirect_variable, variable,
                                          Qt, user_variable_p_eh)))
    return Qnil;

  while (1)
    {
      documentation = Fget (variable, Qvariable_documentation);
      if (INTEGERP (documentation) && XINT (documentation) < 0)
        return Qt;
      if (STRINGP (documentation)
          && ((unsigned char) SREF (documentation, 0) == '*'))
        return Qt;
      /* If it is (STRING . INTEGER), a negative integer means a user variable.  */
      if (CONSP (documentation)
          && STRINGP (XCAR (documentation))
          && INTEGERP (XCDR (documentation))
          && XINT (XCDR (documentation)) < 0)
        return Qt;
      /* Customizable?  See `custom-variable-p'.  */
      if ((!NILP (Fget (variable, intern ("standard-value"))))
          || (!NILP (Fget (variable, intern ("custom-autoload")))))
        return Qt;

      if (!(XSYMBOL (variable)->redirect == SYMBOL_VARALIAS))
        return Qnil;

      /* An indirect variable?  Let's follow the chain.  */
      XSETSYMBOL (variable, SYMBOL_ALIAS (XSYMBOL (variable)));
    }
}

  do
    {
      last_time = catchlist == catch;

      /* Unwind the specpdl stack, and then restore the proper set of
         handlers.  */
      unbind_to (catchlist->pdlcount, Qnil);
      handlerlist = catchlist->handlerlist;
      catchlist = catchlist->next;
    }
  while (! last_time);

#if HAVE_X_WINDOWS
  /* If x_catch_errors was done, turn it off now.
     (First we give unbind_to a chance to do that.)  */
#if 0 /* This would disable x_catch_errors after x_connection_closed.
       * The catch must remain in effect during that delicate
       * state. --lorentey  */
  x_fully_uncatch_errors ();
#endif
#endif

  byte_stack_list = catch->byte_stack;

instead of a single condition name.  Then it handles all of them.

When a handler handles an error, control returns to the `condition-case'
and it executes the handler's BODY...
with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
(If VAR is nil, the handler can't access that information.)
Then the value of the last BODY form is returned from the `condition-case'
expression.

See also the function `signal' for more info.
usage: (condition-case VAR BODYFORM &rest HANDLERS)  */)
(Lisp_Object args)
{
  register Lisp_Object bodyform, handlers;
  volatile Lisp_Object var;

  var      = Fcar (args);

  c.gcpro = gcprolist;
  c.byte_stack = byte_stack_list;
  if (_setjmp (c.jmp))
    {
      if (!NILP (h.var))
        specbind (h.var, c.val);
      val = Fprogn (Fcdr (h.chosen_clause));

      /* Note that this just undoes the binding of h.var; whoever
	 longjumped to us unwound the stack to c.pdlcount before
	 throwing. */

  return val;
}


static Lisp_Object find_handler_clause (Lisp_Object, Lisp_Object,
                                        Lisp_Object, Lisp_Object);

DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
       doc: /* Signal an error.  Args are ERROR-SYMBOL and associated DATA.
This function does not return.

/* Signal `error' with message S, and additional arg ARG.
   If ARG is not a genuine list, make it a one-element list.  */

void
signal_error (char *s, Lisp_Object arg)
{
  Lisp_Object tortoise, hare;

  hare = tortoise = arg;
  while (CONSP (hare))

/* dump an error message; called like printf */

/* VARARGS 1 */
void
error (m, a1, a2, a3)
     char *m;
     char *a1, *a2, *a3;
{
  char buf[200];
  int size = 200;
  int mlen;
  char *buffer = buf;
  char *args[3];
  int allocated = 0;
  Lisp_Object string;

  args[0] = a1;
  args[1] = a2;
  args[2] = a3;

  mlen = strlen (m);

  while (1)
    {
      int used = doprnt (buffer, size, m, m + mlen, 3, args);
      if (used < size)
	break;
      size *= 2;
      if (allocated)
	buffer = (char *) xrealloc (buffer, size);


/* Run hook variables in various ways.  */

enum run_hooks_condition {to_completion, until_success, until_failure};
static Lisp_Object run_hook_with_args (int, Lisp_Object *,
                                       enum run_hooks_condition);

DEFUN ("run-hooks", Frun_hooks, Srun_hooks, 0, MANY, 0,
       doc: /* Run each hook in HOOKS.
Each argument should be a symbol, a hook variable.
These symbols are processed in the order specified.

  switch (sym->redirect)
    {
    case SYMBOL_VARALIAS:
      sym = indirect_variable (sym); XSETSYMBOL (symbol, sym); goto start;
    case SYMBOL_PLAINVAL:
	{ /* The most common case is that of a non-constant symbol with a
	     trivial value.  Make that as fast as we can.  */
	  specpdl_ptr->symbol = symbol;
	  specpdl_ptr->old_value = SYMBOL_VAL (sym);
	  specpdl_ptr->func = NULL;
	  ++specpdl_ptr;
	  if (!sym->constant)
	    SET_SYMBOL_VAL (sym, value);
	  else
	    set_internal (symbol, value, Qnil, 1);
	  break;
	}
    case SYMBOL_LOCALIZED:
      if (SYMBOL_BLV (sym)->frame_local)
	error ("Frame-local vars cannot be let-bound");
    case SYMBOL_FORWARDED:
      {

	 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
	 frame.  If WHERE is a buffer or frame, this indicates we
	 bound a variable that had a buffer-local or frame-local
	 binding.  WHERE nil means that the variable had the default
	 value when it was bound.  CURRENT-BUFFER is the buffer that
         was current when the variable was bound.  */
      else if (CONSP (this_binding.symbol))
	{
	  Lisp_Object symbol, where;

	  symbol = XCAR (this_binding.symbol);

109353:d43e7dfda4f1

/* Evaluator for GNU Emacs Lisp interpreter.
   Copyright (C) 1985, 1986, 1987, 1993, 1994, 1995, 1999, 2000, 2001,
		 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
		 Free Software Foundation, Inc.

This file is part of GNU Emacs.

GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by

extern Lisp_Object Qfunction;

static Lisp_Object funcall_lambda (Lisp_Object, int, Lisp_Object*);
static void unwind_to_catch (struct catchtag *, Lisp_Object) NO_RETURN;

void
init_eval_once (void)
{
  specpdl_size = 50;

  GCPRO2 (args, val);

  do
    {
      if (!(argnum++))
	val = Feval (Fcar (args_left));
      else
	Feval (Fcar (args_left));
      args_left = Fcdr (args_left);
    }
  while (!NILP(args_left));

  GCPRO2 (args, val);

  do
    {
      if (!(argnum++))
	val = Feval (Fcar (args_left));
      else
	Feval (Fcar (args_left));
      args_left = Fcdr (args_left);
    }
  while (!NILP (args_left));

      return Qnil;

  /* If indirect and there's an alias loop, don't check anything else.  */
  if (XSYMBOL (variable)->redirect == SYMBOL_VARALIAS
      && NILP (internal_condition_case_1 (lisp_indirect_variable, variable,
					  Qt, user_variable_p_eh)))
    return Qnil;

  while (1)
    {
      documentation = Fget (variable, Qvariable_documentation);
      if (INTEGERP (documentation) && XINT (documentation) < 0)
	return Qt;
      if (STRINGP (documentation)
	  && ((unsigned char) SREF (documentation, 0) == '*'))
	return Qt;
      /* If it is (STRING . INTEGER), a negative integer means a user variable.  */
      if (CONSP (documentation)
	  && STRINGP (XCAR (documentation))
	  && INTEGERP (XCDR (documentation))
	  && XINT (XCDR (documentation)) < 0)
	return Qt;
      /* Customizable?  See `custom-variable-p'.  */
      if ((!NILP (Fget (variable, intern ("standard-value"))))
	  || (!NILP (Fget (variable, intern ("custom-autoload")))))
	return Qt;

      if (!(XSYMBOL (variable)->redirect == SYMBOL_VARALIAS))
	return Qnil;

      /* An indirect variable?  Let's follow the chain.  */
      XSETSYMBOL (variable, SYMBOL_ALIAS (XSYMBOL (variable)));
    }
}

  do
    {
      last_time = catchlist == catch;

      /* Unwind the specpdl stack, and then restore the proper set of
	 handlers.  */
      unbind_to (catchlist->pdlcount, Qnil);
      handlerlist = catchlist->handlerlist;
      catchlist = catchlist->next;
    }
  while (! last_time);

#if HAVE_X_WINDOWS
  /* If x_catch_errors was done, turn it off now.
     (First we give unbind_to a chance to do that.)  */
#if 0 /* This would disable x_catch_errors after x_connection_closed.
	 The catch must remain in effect during that delicate
	 state. --lorentey  */
  x_fully_uncatch_errors ();
#endif
#endif

  byte_stack_list = catch->byte_stack;

instead of a single condition name.  Then it handles all of them.

When a handler handles an error, control returns to the `condition-case'
and it executes the handler's BODY...
with VAR bound to (ERROR-SYMBOL . SIGNAL-DATA) from the error.
\(If VAR is nil, the handler can't access that information.)
Then the value of the last BODY form is returned from the `condition-case'
expression.

See also the function `signal' for more info.
usage: (condition-case VAR BODYFORM &rest HANDLERS)  */)
  (Lisp_Object args)
{
  register Lisp_Object bodyform, handlers;
  volatile Lisp_Object var;

  var      = Fcar (args);

  c.gcpro = gcprolist;
  c.byte_stack = byte_stack_list;
  if (_setjmp (c.jmp))
    {
      if (!NILP (h.var))
	specbind (h.var, c.val);
      val = Fprogn (Fcdr (h.chosen_clause));

      /* Note that this just undoes the binding of h.var; whoever
	 longjumped to us unwound the stack to c.pdlcount before
	 throwing. */

  return val;
}


static Lisp_Object find_handler_clause (Lisp_Object, Lisp_Object,
					Lisp_Object, Lisp_Object);

DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
       doc: /* Signal an error.  Args are ERROR-SYMBOL and associated DATA.
This function does not return.

/* Signal `error' with message S, and additional arg ARG.
   If ARG is not a genuine list, make it a one-element list.  */

void
signal_error (const char *s, Lisp_Object arg)
{
  Lisp_Object tortoise, hare;

  hare = tortoise = arg;
  while (CONSP (hare))

/* dump an error message; called like printf */

/* VARARGS 1 */
void
error (const char *m, ...)
{
  char buf[200];
  int size = 200;
  int mlen;
  char *buffer = buf;
  char *args[3];
  int allocated = 0;
  Lisp_Object string;

  mlen = strlen (m);

  while (1)
    {
      va_list ap;
      int used;

      /* A va_list can't be reused if we have to go around the loop
	 again; we need to "reinitialize" it each time.  */
      va_start(ap, m);
      used = doprnt (buffer, size, m, m + mlen, ap);
      va_end(ap);
      if (used < size)
	break;
      size *= 2;
      if (allocated)
	buffer = (char *) xrealloc (buffer, size);


/* Run hook variables in various ways.  */

enum run_hooks_condition {to_completion, until_success, until_failure};
static Lisp_Object run_hook_with_args (int, Lisp_Object *,
				       enum run_hooks_condition);

DEFUN ("run-hooks", Frun_hooks, Srun_hooks, 0, MANY, 0,
       doc: /* Run each hook in HOOKS.
Each argument should be a symbol, a hook variable.
These symbols are processed in the order specified.

  switch (sym->redirect)
    {
    case SYMBOL_VARALIAS:
      sym = indirect_variable (sym); XSETSYMBOL (symbol, sym); goto start;
    case SYMBOL_PLAINVAL:
      /* The most common case is that of a non-constant symbol with a
	 trivial value.  Make that as fast as we can.  */
      specpdl_ptr->symbol = symbol;
      specpdl_ptr->old_value = SYMBOL_VAL (sym);
      specpdl_ptr->func = NULL;
      ++specpdl_ptr;
      if (!sym->constant)
	SET_SYMBOL_VAL (sym, value);
      else
	set_internal (symbol, value, Qnil, 1);
      break;
    case SYMBOL_LOCALIZED:
      if (SYMBOL_BLV (sym)->frame_local)
	error ("Frame-local vars cannot be let-bound");
    case SYMBOL_FORWARDED:
      {

	 . CURRENT-BUFFER) where WHERE is either nil, a buffer, or a
	 frame.  If WHERE is a buffer or frame, this indicates we
	 bound a variable that had a buffer-local or frame-local
	 binding.  WHERE nil means that the variable had the default
	 value when it was bound.  CURRENT-BUFFER is the buffer that
	 was current when the variable was bound.  */
      else if (CONSP (this_binding.symbol))
	{
	  Lisp_Object symbol, where;

	  symbol = XCAR (this_binding.symbol);