eval.c

早期freebsd实现

     Lisp_Object handlers, conditions, sig, data;
     Lisp_Object *debugger_value_ptr;
{
  register Lisp_Object h;
  register Lisp_Object tem;
  register Lisp_Object tem1;

  if (EQ (handlers, Qt))  /* t is used by handlers for all conditions, set up by C code.  */
    return Qt;
  if (EQ (handlers, Qerror))  /* error is used similarly, but means display a backtrace too */
    {
      if (stack_trace_on_error)
	internal_with_output_to_temp_buffer ("*Backtrace*", Fbacktrace, Qnil);
      if (EQ (sig, Qquit) ? debug_on_quit : debug_on_error)
	{
	  *debugger_value_ptr =
	    call_debugger (Fcons (Qerror,
				  Fcons (Fcons (sig, data),
					 Qnil)));
	  return Qlambda;
	}
      return Qt;
    }
  for (h = handlers; CONSP (h); h = Fcdr (h))
    {
      tem1 = Fcar (h);
      if (!CONSP (tem1))
	continue;
      tem = Fmemq (Fcar (tem1), conditions);
      if (!NULL (tem))
        return tem1;
    }
  return Qnil;
}

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

/* VARARGS 1 */
void
error (m, a1, a2, a3)
     char *m;
{
  char buf[200];
  sprintf (buf, m, a1, a2, a3);
  while (1)
    Fsignal (Qerror, Fcons (build_string (buf), Qnil));
}

DEFUN ("commandp", Fcommandp, Scommandp, 1, 1, 0,
  "T if FUNCTION makes provisions for interactive calling.\n\
This means it contains a description for how to read arguments to give it.\n\
The value is nil for an invalid function or a symbol with no function definition.\n\
\n\
Interactively callable functions include strings (treated as keyboard macros),\n\
lambda-expressions that contain a top-level call to  interactive ,\n\
autoload definitions made by  autoload  with non-nil fourth argument,\n\
and some of the built-in functions of Lisp.\n\
\n\
Also, a symbol is commandp if its function definition is commandp.")
  (function)
     Lisp_Object function;
{
  register Lisp_Object fun;
  register Lisp_Object funcar;
  register Lisp_Object tem;
  register int i = 0;

  fun = function;
  while (XTYPE (fun) == Lisp_Symbol)
    {
      if (++i > 10) return Qnil;
      tem = Ffboundp (fun);
      if (NULL (tem)) return Qnil;
      fun = Fsymbol_function (fun);
    }
  if (XTYPE (fun) == Lisp_Subr)
    if (XSUBR (fun)->prompt)
      return Qt;
    else
      return Qnil;
  if (XTYPE (fun) == Lisp_Vector || XTYPE (fun) == Lisp_String)
    return Qt;
  if (!CONSP (fun))
    return Qnil;
  funcar = Fcar (fun);
  if (XTYPE (funcar) != Lisp_Symbol)
    return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
  if (EQ (funcar, Qlambda))
    return Fassq (Qinteractive, Fcdr (Fcdr (fun)));
  if (EQ (funcar, Qmocklisp))
    return Qt;  /* All mocklisp functions can be called interactively */
  if (EQ (funcar, Qautoload))
    return Fcar (Fcdr (Fcdr (Fcdr (fun))));
  else
    return Qnil;
}

/* ARGSUSED */
DEFUN ("autoload", Fautoload, Sautoload, 2, 5, 0,
  "Define FUNCTION to autoload from FILE.\n\
FUNCTION is a symbol; FILE is a file name string to pass to  load.\n\
Third arg DOCSTRING is documentation for the function.\n\
Fourth arg FROM_KBD if non-nil says function can be called interactively.\n\
Fifth arg MACRO if non-nil says the function is really a macro.\n\
Third through fifth args give info about the real definition.\n\
They default to nil.\n\
If FUNCTION is already defined other than as an autoload,\n\
this does nothing and returns nil.")
  (function, file, docstring, interactive, macro)
     Lisp_Object function, file, docstring, interactive, macro;
{
#ifdef NO_ARG_ARRAY
  Lisp_Object args[4];
#endif

  CHECK_SYMBOL (function, 0);
  CHECK_STRING (file, 1);

  /* If function is defined and not as an autoload, don't override */
  if (!EQ (XSYMBOL (function)->function, Qunbound)
      && !(XTYPE (XSYMBOL (function)->function) == Lisp_Cons
	   && EQ (XCONS (XSYMBOL (function)->function)->car, Qautoload)))
    return Qnil;

#ifdef NO_ARG_ARRAY
  args[0] = file;
  args[1] = docstring;
  args[2] = interactive;
  args[3] = macro;

  return Ffset (function, Fcons (Qautoload, Flist (4, &args[0])));
#else /* NO_ARG_ARRAY */
  return Ffset (function, Fcons (Qautoload, Flist (4, &file)));
#endif /* not NO_ARG_ARRAY */
}

Lisp_Object
un_autoload (oldqueue)
     Lisp_Object oldqueue;
{
  register Lisp_Object queue, first, second;

  /* Queue to unwind is current value of Vautoload_queue.
     oldqueue is the shadowed value to leave in Vautoload_queue.  */
  queue = Vautoload_queue;
  Vautoload_queue = oldqueue;
  while (CONSP (queue))
    {
      first = Fcar (queue);
      second = Fcdr (first);
      first = Fcar (first);
      if (EQ (second, Qnil))
	Vfeatures = first;
      else
	Ffset (first, second);
      queue = Fcdr (queue);
    }
  return Qnil;
}

do_autoload (fundef, funname)
     Lisp_Object fundef, funname;
{
  int count = specpdl_ptr - specpdl;
  Lisp_Object fun, val;

  fun = funname;

  /* Value saved here is to be restored into Vautoload_queue */
  record_unwind_protect (un_autoload, Vautoload_queue);
  Vautoload_queue = Qt;
  Fload (Fcar (Fcdr (fundef)), Qnil, noninteractive ? Qt : Qnil, Qnil);
  /* Once loading finishes, don't undo it.  */
  Vautoload_queue = Qt;
  unbind_to (count);

  while (XTYPE (fun) == Lisp_Symbol)
    {
      QUIT;
      val = XSYMBOL (fun)->function;
      if (EQ (val, Qunbound))
	Fsymbol_function (fun);	/* Get the right kind of error! */
      fun = val;
    }
  if (XTYPE (fun) == Lisp_Cons
      && EQ (XCONS (fun)->car, Qautoload))
    error ("Autoloading failed to define function %s",
	   XSYMBOL (funname)->name->data);
}

DEFUN ("eval", Feval, Seval, 1, 1, 0,
  "Evaluate FORM and return its value.")
  (form)
     Lisp_Object form;
{
  Lisp_Object fun, val, original_fun, original_args;
  Lisp_Object funcar;
  struct backtrace backtrace;
  struct gcpro gcpro1, gcpro2, gcpro3;

  if (XTYPE (form) == Lisp_Symbol)
    {
      if (EQ (Vmocklisp_arguments, Qt))
        return Fsymbol_value (form);
      val = Fsymbol_value (form);
      if (NULL (val))
	XFASTINT (val) = 0;
      else if (EQ (val, Qt))
	XFASTINT (val) = 1;
      return val;
    }
  if (!CONSP (form))
    return form;

  QUIT;
  if (consing_since_gc > gc_cons_threshold)
    {
      GCPRO1 (form);
      Fgarbage_collect ();
      UNGCPRO;
    }

  if (++lisp_eval_depth > max_lisp_eval_depth)
    {
      if (max_lisp_eval_depth < 100)
	max_lisp_eval_depth = 100;
      if (lisp_eval_depth > max_lisp_eval_depth)
	error ("Lisp nesting exceeds max-lisp-eval-depth");
    }

  original_fun = Fcar (form);
  original_args = Fcdr (form);

  backtrace.next = backtrace_list;
  backtrace_list = &backtrace;
  backtrace.function = &original_fun; /* This also protects them from gc */
  backtrace.args = &original_args;
  backtrace.nargs = UNEVALLED;
  backtrace.evalargs = 1;
  backtrace.debug_on_exit = 0;

  if (debug_on_next_call)
    do_debug_on_call (Qt);

  /* At this point, only original_fun and original_args
     have values that will be used below */
 retry:
  fun = original_fun;
  while (XTYPE (fun) == Lisp_Symbol)
    {
      QUIT;
      val = XSYMBOL (fun)->function;
      if (EQ (val, Qunbound))
	Fsymbol_function (fun);	/* Get the right kind of error! */
      fun = val;
    }

  if (XTYPE (fun) == Lisp_Subr)
    {
      Lisp_Object numargs;
      Lisp_Object argvals[5];
      Lisp_Object args_left;
      register int i, maxargs;

      args_left = original_args;
      numargs = Flength (args_left);

      if (XINT (numargs) < XSUBR (fun)->min_args ||
	  (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < XINT (numargs)))
	return Fsignal (Qwrong_number_of_arguments, Fcons (fun, Fcons (numargs, Qnil)));

      if (XSUBR (fun)->max_args == UNEVALLED)
	{
	  backtrace.evalargs = 0;
	  val = (*XSUBR (fun)->function) (args_left);
	  goto done;
	}

      if (XSUBR (fun)->max_args == MANY)
	{
	  /* Pass a vector of evaluated arguments */
	  Lisp_Object *vals;
	  register int argnum = 0;

	  vals = (Lisp_Object *) alloca (XINT (numargs) * sizeof (Lisp_Object));

	  GCPRO3 (args_left, fun, fun);
	  gcpro3.var = vals;
	  gcpro3.nvars = 0;

	  while (!NULL (args_left))
	    {
	      vals[argnum++] = Feval (Fcar (args_left));
	      args_left = Fcdr (args_left);
	      gcpro3.nvars = argnum;
	    }
	  UNGCPRO;

	  backtrace.args = vals;
	  backtrace.nargs = XINT (numargs);

	  val = (*XSUBR (fun)->function) (XINT (numargs), vals);
	  goto done;
	}

      GCPRO3 (args_left, fun, fun);
      gcpro3.var = argvals;
      gcpro3.nvars = 0;

      maxargs = XSUBR (fun)->max_args;
      for (i = 0; i < maxargs; args_left = Fcdr (args_left))
	{
	  argvals[i] = Feval (Fcar (args_left));
	  gcpro3.nvars = ++i;
	}

      UNGCPRO;

      backtrace.args = argvals;
      backtrace.nargs = XINT (numargs);

      switch (i)
	{
	case 0:
	  val = (*XSUBR (fun)->function) ();
	  goto done;
	case 1:
	  val = (*XSUBR (fun)->function) (argvals[0]);
	  goto done;
	case 2:
	  val = (*XSUBR (fun)->function) (argvals[0], argvals[1]);
	  goto done;
	case 3:
	  val = (*XSUBR (fun)->function) (argvals[0], argvals[1],
					  argvals[2]);
	  goto done;
	case 4:
	  val = (*XSUBR (fun)->function) (argvals[0], argvals[1],
					  argvals[2], argvals[3]);
	  goto done;
	case 5:
	  val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
					  argvals[3], argvals[4]);
	  goto done;
	}
    }
  if (!CONSP (fun))
    return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
  funcar = Fcar (fun);
  if (XTYPE (funcar) != Lisp_Symbol)
    return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
  if (EQ (funcar, Qautoload))
    {
      do_autoload (fun, original_fun);
      goto retry;
    }
  if (EQ (funcar, Qmacro))
    val = Feval (apply1 (Fcdr (fun), original_args));
  else if (EQ (funcar, Qlambda))
    val = apply_lambda (fun, original_args, 1);
  else if (EQ (funcar, Qmocklisp))
    val = ml_apply (fun, original_args);
  else
    return Fsignal (Qinvalid_function, Fcons (fun, Qnil));

 done:
  if (!EQ (Vmocklisp_arguments, Qt))
    {
      if (NULL (val))
	XFASTINT (val) = 0;
      else if (EQ (val, Qt))
	XFASTINT (val) = 1;
    }
  lisp_eval_depth--;
  if (backtrace.debug_on_exit)
    val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
  backtrace_list = backtrace.next;
  return val;
}

DEFUN ("apply", Fapply, Sapply, 2, MANY, 0,
  "Call FUNCTION, passing remaining arguments to it.  The last argument\n\
is a list of arguments to pass.\n\
Thus, (apply '+ 1 2 '(3 4)) returns 10.")
  (nargs, args)
     int nargs;
     Lisp_Object *args;
{
  register int i, numargs;
  register Lisp_Object spread_arg;
  register Lisp_Object *funcall_args ;
  Lisp_Object fun;

  fun = args [0];
  funcall_args = 0;
  spread_arg = args [nargs - 1];
  CHECK_LIST (spread_arg, nargs);
  
  numargs = XINT (Flength (spread_arg));

  if (numargs == 0)
    return Ffuncall (nargs - 1, args);
  else if (numargs == 1)
    {
      args [nargs - 1] = XCONS (spread_arg)->car;
      return Ffuncall (nargs, args);
    }

  numargs = nargs - 2 + numargs;

  while (XTYPE (fun) == Lisp_Symbol)
    {
      QUIT;
      fun = XSYMBOL (fun)->function;
      if (EQ (fun, Qunbound))
	{
	  /* Let funcall get the error */
	  fun = args[0];
	  goto funcall;
	}
    }

  if (XTYPE (fun) == Lisp_Subr)
    if (numargs < XSUBR (fun)->min_args ||
	(XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
      goto funcall;		/* Let funcall get the error */
    else if (XSUBR (fun)->max_args > numargs)
      {
        /* Avoid making funcall cons up a yet another new vector of arguments
	   by explicitly supplying nil's for optional values */
	funcall_args = (Lisp_Object *) alloca ((1 + XSUBR (fun)->max_args)
					       * sizeof (Lisp_Object));
	for (i = numargs; i < XSUBR (fun)->max_args;)
	  funcall_args[++i] = Qnil;
      }
 funcall:
  /* We add 1 to numargs because funcall_args includes the
     function itself as well as its arguments.  */
  if (!funcall_args)
    funcall_args = (Lisp_Object *) alloca ((1 + numargs)
					   * sizeof (Lisp_Object));
  bcopy (args, funcall_args, nargs * sizeof (Lisp_Object));
  /* Spread the last arg we got.  Its first element goes in
     the slot that it used to occupy, hence this value of I.  */
  i = nargs - 1;
  while (!NULL (spread_arg))
    {
      funcall_args [i++] = XCONS (spread_arg)->car;
      spread_arg = XCONS (spread_arg)->cdr;
    }
  return Ffuncall (numargs + 1, funcall_args);
}

/* Apply fn to arg */
Lisp_Object
apply1 (fn, arg)
     Lisp_Object fn, arg;
{
  if (NULL (arg))
    return Ffuncall (1, &fn);
#ifdef NO_ARG_ARRAY
  {
    Lisp_Object args[2];
    args[0] = fn;
    args[1] = arg;
    return Fapply (2, args);
  }
#else /* not NO_ARG_ARRAY */
  return Fapply (2, &fn);
#endif /* not NO_ARG_ARRAY */
}

/* Call function fn on no arguments */
Lisp_Object
call0 (fn)
     Lisp_Object fn;
{
  return Ffuncall (1, &fn);
}

/* Call function fn with argument arg */
/* ARGSUSED */
Lisp_Object
call1 (fn, arg)
     Lisp_Object fn, arg;
{
#ifdef NO_ARG_ARRAY
  Lisp_Object args[2];
  args[0] = fn;
  args[1] = arg;
  return Ffuncall (2, args);
#else /* not NO_ARG_ARRAY */
  return Ffuncall (2, &fn);
#endif /* not NO_ARG_ARRAY */
}

/* Call function fn with arguments arg, arg1 */
/* ARGSUSED */
Lisp_Object
call2 (fn, arg, arg1)
     Lisp_Object fn, arg, arg1;
{
#ifdef NO_ARG_ARRAY
  Lisp_Object args[3];
  args[0] = fn;
  args[1] = arg;
  args[2] = arg1;
  return Ffuncall (3, args);
#else /* not NO_ARG_ARRAY */
  return Ffuncall (3, &fn);
#endif /* not NO_ARG_ARRAY */
}

/* Call function fn with arguments arg, arg1, arg2 */
/* ARGSUSED */
Lisp_Object
call3 (fn, arg, arg1, arg2)
     Lisp_Object fn, arg, arg1, arg2;
{
#ifdef NO_ARG_ARRAY
  Lisp_Object args[4];
  args[0] = fn;
  args[1] = arg;
  args[2] = arg1;
  args[3] = arg2;
  return Ffuncall (4, args);
#else /* not NO_ARG_ARRAY */
  return Ffuncall (4, &fn);
#endif /* not NO_ARG_ARRAY */
}

DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
  "Call first argument as a function, passing remaining arguments to it.\n\
Thus,  (funcall 'cons 'x 'y)  returns  (x . y).")
  (nargs, args)
     int nargs;
     Lisp_Object *args;
{
  Lisp_Object fun;