eval.c

早期freebsd实现

The intent is that programs do not change this value (but users may).\n\
Always sets the value of SYMBOL to the result of evalling INITVALUE.\n\
DOCSTRING is optional.\n\
If DOCSTRING starts with *, this variable is identified as a user option.\n\
 This means that M-x set-variable and M-x edit-options recognize it.")
  (args)
     Lisp_Object args;
{
  register Lisp_Object sym, tem;

  sym = Fcar (args);
  Fset (sym, Feval (Fcar (Fcdr (args))));
  tem = Fcar (Fcdr (Fcdr (args)));
  if (!NULL (tem))
    {
      if (!NULL (Vpurify_flag))
	tem = Fpurecopy (tem);
      Fput (sym, Qvariable_documentation, tem);
    }
  return sym;
}

DEFUN ("user-variable-p", Fuser_variable_p, Suser_variable_p, 1, 1, 0,
  "Returns t if VARIABLE is intended to be set and modified by users,\n\
as opposed to by programs.\n\
Determined by whether the first character of the documentation\n\
for the variable is \"*\"")
  (variable)
     Lisp_Object variable;
{
  Lisp_Object documentation;
  
  documentation = Fget (variable, Qvariable_documentation);
  if (XTYPE (documentation) == Lisp_Int && XINT (documentation) < 0)
    return Qt;
  if ((XTYPE (documentation) == Lisp_String) &&
      ((unsigned char) XSTRING (documentation)->data[0] == '*'))
    return Qt;
  return Qnil;
}  

DEFUN ("let*", FletX, SletX, 1, UNEVALLED, 0,
  "(let* VARLIST BODY...) binds variables according to VARLIST then executes BODY.\n\
The value of the last form in BODY is returned.\n\
Each element of VARLIST is a symbol (which is bound to NIL)\n\
or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
Each VALUEFORM can refer to the symbols already bound by this VARLIST.")
  (args)
     Lisp_Object args;
{
  Lisp_Object varlist, val, elt;
  int count = specpdl_ptr - specpdl;
  struct gcpro gcpro1, gcpro2, gcpro3;

  GCPRO3 (args, elt, varlist);

  varlist = Fcar (args);
  while (!NULL (varlist))
    {
      QUIT;
      elt = Fcar (varlist);
      if (XTYPE (elt) == Lisp_Symbol)
	specbind (elt, Qnil);
      else
	{
	  val = Feval (Fcar (Fcdr (elt)));
	  specbind (Fcar (elt), val);
	}
      varlist = Fcdr (varlist);
    }
  UNGCPRO;
  val = Fprogn (Fcdr (args));
  unbind_to (count);
  return val;
}

DEFUN ("let", Flet, Slet, 1, UNEVALLED, 0,
  "(let VARLIST BODY...) binds variables according to VARLIST then executes BODY.\n\
The value of the last form in BODY is returned.\n\
Each element of VARLIST is a symbol (which is bound to NIL)\n\
or a list (SYMBOL VALUEFORM) (which binds SYMBOL to the value of VALUEFORM).\n\
All the VALUEFORMs are evalled before any symbols are bound.")
  (args)
     Lisp_Object args;
{
  Lisp_Object *temps, tem;
  register Lisp_Object elt, varlist;
  int count = specpdl_ptr - specpdl;
  register int argnum;
  struct gcpro gcpro1, gcpro2;

  varlist = Fcar (args);

  /* Make space to hold the values to give the bound variables */
  elt = Flength (varlist);
  temps = (Lisp_Object *) alloca (XFASTINT (elt) * sizeof (Lisp_Object));

  /* Compute the values and store them in `temps' */

  GCPRO2 (args, *temps);
  gcpro2.nvars = 0;

  for (argnum = 0; !NULL (varlist); varlist = Fcdr (varlist))
    {
      QUIT;
      elt = Fcar (varlist);
      if (XTYPE (elt) == Lisp_Symbol)
	temps [argnum++] = Qnil;
      else
	temps [argnum++] = Feval (Fcar (Fcdr (elt)));
      gcpro2.nvars = argnum;
    }
  UNGCPRO;

  varlist = Fcar (args);
  for (argnum = 0; !NULL (varlist); varlist = Fcdr (varlist))
    {
      elt = Fcar (varlist);
      tem = temps[argnum++];
      if (XTYPE (elt) == Lisp_Symbol)
	specbind (elt, tem);
      else
	specbind (Fcar (elt), tem);
    }

  elt = Fprogn (Fcdr (args));
  unbind_to (count);
  return elt;
}

DEFUN ("while", Fwhile, Swhile, 1, UNEVALLED, 0,
  "(while TEST BODY...) if TEST yields non-NIL, execute the BODY forms and repeat.")
  (args)
     Lisp_Object args;
{
  Lisp_Object test, body, tem;
  struct gcpro gcpro1, gcpro2;

  GCPRO2 (test, body);

  test = Fcar (args);
  body = Fcdr (args);
  while (tem = Feval (test), !NULL (tem))
    {
      QUIT;
      Fprogn (body);
    }

  UNGCPRO;
  return Qnil;
}

DEFUN ("macroexpand", Fmacroexpand, Smacroexpand, 1, 2, 0,
  "If FORM is a macro call, expand it.\n\
If the result of expansion is another macro call, expand it, etc.\n\
Return the ultimate expansion.\n\
The second optional arg ENVIRONMENT species an environment of macro\n\
definitions to shadow the loaded ones for use in file byte-compilation.")
  (form, env)
     register Lisp_Object form;
     Lisp_Object env;
{
  register Lisp_Object expander, sym, def, tem;

  while (1)
    {
      /* Come back here each time we expand a macro call,
	 in case it expands into another macro call.  */
      if (XTYPE (form) != Lisp_Cons)
	break;
      sym = XCONS (form)->car;
      if (XTYPE (sym) != Lisp_Symbol)
	break;
      /* Trace symbols aliases to other symbols
	 until we get a symbol that is not an alias.  */
      while (1)
	{
	  QUIT;
	  tem = Fassq (sym, env);
	  if (NULL (tem))
	    {
	      def = XSYMBOL (sym)->function;
	      if (XTYPE (def) == Lisp_Symbol && !EQ (def, Qunbound))
		sym = def;
	      else
		break;
	    }
	  else
	    {
	      if (XTYPE (tem) == Lisp_Cons
		  && XTYPE (XCONS (tem)->cdr) == Lisp_Symbol)
		sym = XCONS (tem)->cdr;
	      else
		break;
	    }
	}
      /* Right now TEM is the result from SYM in ENV,
	 and if TEM is nil then DEF is SYM's function definition.  */
      if (NULL (tem))
	{
	  /* SYM is not mentioned in ENV.
	     Look at its function definition.  */
	  if (EQ (def, Qunbound)
	      || XTYPE (def) != Lisp_Cons)
	    /* Not defined or definition not suitable */
	    break;
	  if (EQ (XCONS (def)->car, Qautoload))
	    {
	      /* Autoloading function: will it be a macro when loaded?  */
	      tem = Fcar (Fnthcdr (make_number (4), def));
	      if (NULL (tem))
		break;
	      /* Yes, load it and try again.  */
	      do_autoload (def, sym);
	      continue;
	    }
	  else if (!EQ (XCONS (def)->car, Qmacro))
	    break;
	  else expander = XCONS (def)->cdr;
	}
      else
	{
	  expander = XCONS (tem)->cdr;
	  if (NULL (expander))
	    break;
	}
      form = apply1 (expander, XCONS (form)->cdr);
    }
  return form;
}

DEFUN ("catch", Fcatch, Scatch, 1, UNEVALLED, 0,
  "(catch TAG BODY...) perform BODY allowing nonlocal exits using (throw TAG).\n\
TAG is evalled to get the tag to use.  throw  to that tag exits this catch.\n\
Then the BODY is executed.  If no  throw  happens, the value of the last BODY\n\
form is returned from  catch.  If a  throw  happens, it specifies the value to\n\
return from  catch.")
  (args)
     Lisp_Object args;
{
  register Lisp_Object tag;
  struct gcpro gcpro1;

  GCPRO1 (args);
  tag = Feval (Fcar (args));
  UNGCPRO;
  return internal_catch (tag, Fprogn, Fcdr (args));
}

/* Set up a catch, then call C function FUNC on argument ARG.
   FUNC should return a Lisp_Object.
   This is how catches are done from within C code. */

Lisp_Object
internal_catch (tag, func, arg)
     Lisp_Object tag;
     Lisp_Object (*func) ();
     Lisp_Object arg;
{
  /* This structure is made part of the chain `catchlist'.  */
  struct catchtag c;

  /* Fill in the components of c, and put it on the list.  */
  c.next = catchlist;
  c.tag = tag;
  c.val = Qnil;
  c.backlist = backtrace_list;
  c.lisp_eval_depth = lisp_eval_depth;
  c.poll_suppress_count = poll_suppress_count;
  c.pdlcount = specpdl_ptr - specpdl;
  c.gcpro = gcprolist;
  catchlist = &c;

  /* Call FUNC.  */
  if (! _setjmp (c.jmp))
    c.val = (*func) (arg);

  /* Throw works by a longjmp that comes right here.  */
  catchlist = c.next;
  return c.val;
}

/* Discard from the catchlist all catch tags back through CATCH.
   Before each catch is discarded, unbind all special bindings
   made within that catch.  Also, when discarding a catch that
   corresponds to a condition handler, discard that handler.

   At the end, restore some static info saved in CATCH.

   This is used for correct unwinding in Fthrow and Fsignal,
   before doing the longjmp that actually destroys the stack frames
   in which these handlers and catches reside.  */

static void
unbind_catch (catch)
     struct catchtag *catch;
{
  register int last_time;

  do
    {
      last_time = catchlist == catch;
      unbind_to (catchlist->pdlcount);
      if (handlerlist != 0 && handlerlist->tag == catchlist)
	handlerlist = handlerlist->next;
      catchlist = catchlist->next;
    }
  while (! last_time);

  gcprolist = catch->gcpro;
  backtrace_list = catch->backlist;
  lisp_eval_depth = catch->lisp_eval_depth;
}

DEFUN ("throw", Fthrow, Sthrow, 2, 2, 0,
  "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.\n\
Both TAG and VALUE are evalled.")
  (tag, val)
     register Lisp_Object tag, val;
{
  register struct catchtag *c;

  while (1)
    {
      if (!NULL (tag))
	for (c = catchlist; c; c = c->next)
	  {
	    if (EQ (c->tag, tag))
	      {
		/* Restore the polling-suppression count.  */
		if (c->poll_suppress_count > poll_suppress_count)
		  abort ();
		while (c->poll_suppress_count < poll_suppress_count)
		  start_polling ();
		c->val = val;
		unbind_catch (c);
		_longjmp (c->jmp, 1);
	      }
	  }
      tag = Fsignal (Qno_catch, Fcons (tag, Fcons (val, Qnil)));
    }
}


DEFUN ("unwind-protect", Funwind_protect, Sunwind_protect, 1, UNEVALLED, 0,
  "Do BODYFORM, protecting with UNWINDFORMS.\n\
Usage looks like (unwind-protect BODYFORM UNWINDFORMS...) \n\
If BODYFORM completes normally, its value is returned\n\
after executing the UNWINDFORMS.\n\
If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway.")
  (args)
     Lisp_Object args;
{
  Lisp_Object val;
  int count = specpdl_ptr - specpdl;
  struct gcpro gcpro1;

  record_unwind_protect (0, Fcdr (args));
  val = Feval (Fcar (args));
  GCPRO1 (val);
  unbind_to (count);  
  UNGCPRO;
  return val;
}

/* Chain of condition handlers currently in effect.
   The elements of this chain are contained in the stack frames
   of Fcondition_case and internal_condition_case.
   When an error is signaled (by calling Fsignal, below),
   this chain is searched for an element that applies.  */

struct handler *handlerlist;

DEFUN ("condition-case", Fcondition_case, Scondition_case, 2, UNEVALLED, 0,
  "Regain control when an error is signaled.\n\
 (condition-case VAR BODYFORM HANDLERS...)\n\
executes BODYFORM and returns its value if no error happens.\n\
Each element of HANDLERS looks like (CONDITION-NAME BODY...)\n\
where the BODY is made of Lisp expressions.\n\
The handler is applicable to an error\n\
if CONDITION-NAME is one of the error's condition names.\n\
When a handler handles an error,\n\
control returns to the condition-case and the handler BODY... is executed\n\
with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).\n\
The value of the last BODY form is returned from the condition-case.\n\
See SIGNAL for more info.")
  (args)
     Lisp_Object args;
{
  Lisp_Object val;
  struct catchtag c;
  struct handler h;
  register Lisp_Object tem;

  tem = Fcar (args);
  CHECK_SYMBOL (tem, 0);

  c.tag = Qnil;
  c.val = Qnil;
  c.backlist = backtrace_list;
  c.lisp_eval_depth = lisp_eval_depth;
  c.poll_suppress_count = poll_suppress_count;
  c.pdlcount = specpdl_ptr - specpdl;
  c.gcpro = gcprolist;
  if (_setjmp (c.jmp))
    {
      if (!NULL (h.var))
        specbind (h.var, Fcdr (c.val));
      val = Fprogn (Fcdr (Fcar (c.val)));
      unbind_to (c.pdlcount);
      return val;
    }
  c.next = catchlist;
  catchlist = &c;
  h.var = Fcar (args);
  h.handler = Fcdr (Fcdr (args));
  
  for (val = h.handler; ! NULL (val); val = Fcdr (val))
    {
      tem = Fcar (val);
      if ((!NULL (tem)) &&
	  (!CONSP (tem) || (XTYPE (XCONS (tem)->car) != Lisp_Symbol)))
	error ("Invalid condition handler", tem);
    }
  
  h.next = handlerlist;
  h.poll_suppress_count = poll_suppress_count;
  h.tag = &c;
  handlerlist = &h;

  val = Feval (Fcar (Fcdr (args)));
  catchlist = c.next;
  handlerlist = h.next;
  return val;
}

Lisp_Object
internal_condition_case (bfun, handlers, hfun)
     Lisp_Object (*bfun) ();
     Lisp_Object handlers;
     Lisp_Object (*hfun) ();
{
  Lisp_Object val;
  struct catchtag c;
  struct handler h;

  c.tag = Qnil;
  c.val = Qnil;
  c.backlist = backtrace_list;
  c.lisp_eval_depth = lisp_eval_depth;
  c.poll_suppress_count = poll_suppress_count;
  c.pdlcount = specpdl_ptr - specpdl;
  c.gcpro = gcprolist;
  if (_setjmp (c.jmp))
    {
      return (*hfun) (Fcdr (c.val));
    }
  c.next = catchlist;
  catchlist = &c;
  h.handler = handlers;
  h.var = Qnil;
  h.poll_suppress_count = poll_suppress_count;
  h.next = handlerlist;
  h.tag = &c;
  handlerlist = &h;

  val = (*bfun) ();
  catchlist = c.next;
  handlerlist = h.next;
  return val;
}

static Lisp_Object find_handler_clause ();

DEFUN ("signal", Fsignal, Ssignal, 2, 2, 0,
  "Signal an error.  Args are SIGNAL-NAME, and associated DATA.\n\
A signal name is a symbol with an  error-conditions  property\n\
that is a list of condition names.\n\
A handler for any of those names will get to handle this signal.\n\
The symbol  error  should always be one of them.\n\
\n\
DATA should be a list.  Its elements are printed as part of the error message.\n\
If the signal is handled, DATA is made available to the handler.\n\
See  condition-case.")
  (sig, data)
     Lisp_Object sig, data;
{
  register struct handler *allhandlers = handlerlist;
  Lisp_Object conditions;
  extern int gc_in_progress;
  extern int waiting_for_input;
  Lisp_Object debugger_value;

  quit_error_check ();
  immediate_quit = 0;
  if (gc_in_progress || waiting_for_input)
    abort ();

  conditions = Fget (sig, Qerror_conditions);

  for (; handlerlist; handlerlist = handlerlist->next)
    {
      register Lisp_Object clause;
      clause = find_handler_clause (handlerlist->handler, conditions,
				    sig, data, &debugger_value);

      /* If have called debugger and user wants to continue,
	 just return nil.  */
      if (EQ (clause, Qlambda))
	return debugger_value;

      if (!NULL (clause))
	{
	  struct handler *h = handlerlist;
	  /* Restore the polling-suppression count.  */
	  if (h->poll_suppress_count > poll_suppress_count)
	    abort ();
	  while (h->poll_suppress_count < poll_suppress_count)
	    start_polling ();
	  handlerlist = allhandlers;
	  unbind_catch (h->tag);
	  h->tag->val = Fcons (clause, Fcons (sig, data));
	  _longjmp (h->tag->jmp, 1);
	}
    }

  handlerlist = allhandlers;
  /* If no handler is present now, try to run the debugger,
     and if that fails, throw to top level.  */
  find_handler_clause (Qerror, conditions, sig, data, &debugger_value);
  Fthrow (Qtop_level, Qt);
}

/* Value of Qlambda means we have called debugger and
   user has continued.  Store value returned fromdebugger
   into *debugger_value_ptr */

static Lisp_Object
find_handler_clause (handlers, conditions, sig, data, debugger_value_ptr)