CodeReading: EmacsLisp "eval"関数

Kazuki Ohta, 2005/01/27

学校の課題でSchemeの"eval"関数相当のモノを作った。一度理解してしまえば、Lisp系の処理系の"eval"部分は案外容易に理解出来るものである。それを示す為に、今回はEmacsLispの"eval"関数を見ていく事にしよう(in src/eval.c)。これがEmacsLispの心臓部だ。まずは全体を見通してみる。 
in src/eval.c

DEFUN ("eval", Feval, Seval, 1, 1, 0,
       doc: /* 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 (handling_signal)
    abort ();

  if (SYMBOLP (form))
    return Fsymbol_value (form);
  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 = Findirect_function (original_fun);

  if (SUBRP (fun))
    {
      Lisp_Object numargs;
      Lisp_Object argvals[8];
      Lisp_Object args_left;
      register int i, maxargs;

      args_left = original_args;
      numargs = Flength (args_left);

      CHECK_CONS_LIST ();

      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 (!NILP (args_left))
	    {
	      vals[argnum++] = Feval (Fcar (args_left));
	      args_left = Fcdr (args_left);
	      gcpro3.nvars = argnum;
	    }

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

	  val = (*XSUBR (fun)->function) (XINT (numargs), vals);
	  UNGCPRO;
	  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;
	case 6:
	  val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
					  argvals[3], argvals[4], argvals[5]);
	  goto done;
	case 7:
	  val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
					  argvals[3], argvals[4], argvals[5],
					  argvals[6]);
	  goto done;

	case 8:
	  val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
					  argvals[3], argvals[4], argvals[5],
					  argvals[6], argvals[7]);
	  goto done;

	default:
	  /* Someone has created a subr that takes more arguments than
	     is supported by this code.  We need to either rewrite the
	     subr to use a different argument protocol, or add more
	     cases to this switch.  */
	  abort ();
	}
    }
  if (COMPILEDP (fun))
    val = apply_lambda (fun, original_args, 1);
  else
    {
      if (!CONSP (fun))
	return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
      funcar = Fcar (fun);
      if (!SYMBOLP (funcar))
	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
	return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
    }
 done:
  CHECK_CONS_LIST ();

  lisp_eval_depth--;
  if (backtrace.debug_on_exit)
    val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
  backtrace_list = backtrace.next;

  return val;
}

では最初の方から読み解いて行く事にする。 
DEFUN ("eval", Feval, Seval, 1, 1, 0,
       doc: /* 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 (handling_signal)
    abort ();

  if (SYMBOLP (form))
    return Fsymbol_value (form);
  if (!CONSP (form))
    return form;
DEFUNマクロはEmacsのソースコードの各所で用いられているマクロである。これは、EmacsLispから使用するシンボルを登録し同時にCからも使えるように関数を宣言する為のマクロだ。EmacsLispからは"eval", Cからは"Feval"でこの関数を呼び出せる。Feval関数の引数はLisp_Object型のformが渡される。

まず最初のif文だが、これはsignalを処理中の場合はabortするという内容。次のif文が結構重要。もしformがSymbolならば、その値を返すというもの。Schemeで言うならば、(define a "aiueo")した後に(eval a)すると、aの値"aiueo"が結果として返ってくる。Fsymbol_valueの中身は機会が有れば。最後のif文は、formがcons cellで無かったらそれは何も処理せずにそのまま返すという処理だ。例えば(eval 1) => 1とか。 
  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);
次のif文は、gcに関するものである。consing_since_gcという名前から推測するに、これは前のgcが実行された後から確保されたcons cellの数を保持していて、それがgc_cons_thresholdを越えた場合にはFgarbege_collectを呼び出してゴミを回収する。

その次のif文はネストのチェック。Stack Over Flowを防ぐ為に、ある程度以上のnestingは許さないという仕様になっている。

そして、funとargsを取り出す。(fun arg0 arg1 arg2)というformが渡されて来た場合、original_funはfun、original_argsは(arg0 arg1 arg2)となる。formの型はcons cellなので、Fcar, Fcdrしても問題は無い。 
  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 = Findirect_function (original_fun);
お次はdebug用の処理だ。backtrace_listに、evalする内容を次々と連結して行く。backtraceはスタック上に確保されるので、開放する必要はない。

original_funに対してFindirect_functionという関数を呼び出している。これは何かな。以下src/data.cのindirect_function関数の部分を抜き出す。 
DEFUN ("indirect-function", Findirect_function, Sindirect_function, 1, 1, 0,
       doc: /* Return the function at the end of OBJECT's function chain.
If OBJECT is a symbol, follow all function indirections and return the final
function binding.
If OBJECT is not a symbol, just return it.
Signal a void-function error if the final symbol is unbound.
Signal a cyclic-function-indirection error if there is a loop in the
function chain of symbols.  */)
     (object)
     register Lisp_Object object;
{
  Lisp_Object result;

  result = indirect_function (object);

  if (EQ (result, Qunbound))
    return Fsignal (Qvoid_function, Fcons (object, Qnil));
  return result;
}
コメントやこのコードの周辺を見れば分かるが、これはSymbolの値を元にFunctionの実態を返す関数だ。original_funはあくまでシンボルに過ぎず、この関数を使う事で実際の関数の内容を引っ張ってきている事が分かる。

引っ張ってきた内容がQunboundだと、エラーシグナルが投げられている事が分かる。さて、evalに戻ろう。 
  if (SUBRP (fun))
    {
      Lisp_Object numargs;
      Lisp_Object argvals[8];
      Lisp_Object args_left;
      register int i, maxargs;

      args_left = original_args;
      numargs = Flength (args_left);

      CHECK_CONS_LIST ();

      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)));
まずは、Findirect_functionで得たfunがsubr (Sub Routineの略)型で有る事を確かめる。そうしたら次はついに関数を与えられた引数に作用させる部分に突入だ。

num_argsには引数の長さが入る。その次のif文は多少ややこしいがQwrong_number_of_argumentsというシンボル名から分かるように、引数の数のチェックを行っている。違う個数が与えられた場合はシグナルを発する。

さて、次次。 
      if (XSUBR (fun)->max_args == UNEVALLED)
	{
	  backtrace.evalargs = 0;
	  val = (*XSUBR (fun)->function) (args_left);
	  goto done;
	}
この部分は、funのmax_argsによって処理が別れている。UNEVALLEDと有るが、これはおそらく引数をevalしないタイプの関数をevalする場合の処理だ。引数をevalしない関数って？例えば"if"等の特殊形式と呼ばれるタイプの関数だ。args_leftはoriginal_argsそのものなので、evalに与えられた引数が評価されずにそのまま関数が実行される。 
      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 (!NILP (args_left))
	    {
	      vals[argnum++] = Feval (Fcar (args_left));
	      args_left = Fcdr (args_left);
	      gcpro3.nvars = argnum;
	    }

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

	  val = (*XSUBR (fun)->function) (XINT (numargs), vals);
	  UNGCPRO;
	  goto done;
	}
次は、MANYの場合。これは可変長個数の引数を取れる関数の場合であろう。中央のwhileループでは、args_leftを順番に評価して行き、その結果をallocaで確保したvalsに格納して行く。そして最後にそれをfunへと渡して関数を実行し、処理を終了する。 
      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);
「評価しない」「可変長」と来たら、後は「固定長」しか無い。先ほど可変長の例で見たように、whileループでargs_leftを順番に評価して行きargvals配列に結果を確保して行く。他はGCの処理とか、backtrace用の情報をセットしたりとか。 
      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;
	case 6:
	  val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
					  argvals[3], argvals[4], argvals[5]);
	  goto done;
	case 7:
	  val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
					  argvals[3], argvals[4], argvals[5],
					  argvals[6]);
	  goto done;

	case 8:
	  val = (*XSUBR (fun)->function) (argvals[0], argvals[1], argvals[2],
					  argvals[3], argvals[4], argvals[5],
					  argvals[6], argvals[7]);
	  goto done;

	default:
	  /* Someone has created a subr that takes more arguments than
	     is supported by this code.  We need to either rewrite the
	     subr to use a different argument protocol, or add more
	     cases to this switch.  */
	  abort ();
	}
    }
はい、固定長関数の実行部分。eval関数の心臓部は結構泥臭いです。実行が終わったらdoneへgoto。 
  if (COMPILEDP (fun))
    val = apply_lambda (fun, original_args, 1);
  else
    {
      if (!CONSP (fun))
	return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
      funcar = Fcar (fun);
      if (!SYMBOLP (funcar))
	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
	return Fsignal (Qinvalid_function, Fcons (fun, Qnil));
    }
さて、関数型(SUBRP)のfunは処理しおわった。次はコンパイルされたlambda closure(COMPILEDP)を処理する部分だと思われる。COMPILEDP(fun)ならばapply_lambdaで結果を得る。else部分は主にエラー処理であるので、割愛。マクロの場合や生のlambdaが来た場合の処理なんかも入っている。 
 done:
  CHECK_CONS_LIST ();

  lisp_eval_depth--;
  if (backtrace.debug_on_exit)
    val = call_debugger (Fcons (Qexit, Fcons (val, Qnil)));
  backtrace_list = backtrace.next;

  return val;
}
最後はbacktraceやeval_depthを引く等の事後処理をし、valを返す。

以上、EmacsLispの心臓部でした。ちゃんちゃん。


[ return ]