nucleus: move function calling from apply.d and eval.d to call.d

The file apply.d is effectively removed.

src/c/Makefile.in

@@ -50,7 +50,7 @@ HFILES = $(HDIR)/config.h $(HDIR)/ecl.h $(HDIR)/ecl-cmp.h $(HDIR)/object.h
 	$(HDIR)/impl/math_dispatch.h $(HDIR)/impl/math_fenv.h                   \
 	$(HDIR)/impl/math_fenv_msvc.h $(HDIR)/nucleus.h
 
-NUCL_OBJS =
+NUCL_OBJS = call.o
 
 CLOS_OBJS = clos/cache.o clos/accessor.o clos/instance.o clos/gfun.o
 
@@ -74,7 +74,7 @@ READER_OBJS = read.o reader/parse_integer.o reader/parse_number.o
 
 FFI_OBJS = ffi.o ffi/libraries.o ffi/backtrace.o ffi/mmap.o ffi/cdata.o
 
-OBJS = main.o symbol.o package.o cons.o list.o apply.o eval.o interpreter.o     \
+OBJS = main.o symbol.o package.o cons.o list.o eval.o interpreter.o             \
 	compiler.o disassembler.o reference.o character.o file.o error.o        \
 	string.o cfun.o typespec.o assignment.o memory.o predicate.o array.o    \
 	vector_push.o sequence.o cmpaux.o macros.o backq.o stacks.o time.o      \

src/c/call.d

@@ -1,18 +1,93 @@
 /* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
 /* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */
 
-/*
- * apply.c - interface to C call mechanism
- *
- * Copyright (c) 1993 Giuseppe Attardi
- * Copyright (c) 2001 Juan Jose Garcia Ripoll
- *
- * See file 'LICENSE' for the copyright details.
- *
- */
+/* dispatch.c - function application */
 
 #include <ecl/ecl.h>
+#include <ecl/ecl-inl.h>
 #include <ecl/internal.h>
+#include <ecl/external.h>
+#include <ecl/nucleus.h>
+
+cl_objectfn
+ecl_function_dispatch(cl_env_ptr env, cl_object x)
+{
+  cl_object fun = x;
+  if (ecl_unlikely(fun == ECL_NIL))
+    FEundefined_function(x);
+  switch (ecl_t_of(fun)) {
+  case t_cfunfixed:
+    env->function = fun;
+    return fun->cfunfixed.entry;
+  case t_cfun:
+    env->function = fun;
+    return fun->cfun.entry;
+  case t_cclosure:
+    env->function = fun;
+    return fun->cclosure.entry;
+  case t_instance:
+    env->function = fun;
+    return fun->instance.entry;
+  case t_symbol:
+    fun = ECL_SYM_FUN(fun);
+    env->function = fun;
+    return fun->cfun.entry;
+  case t_bytecodes:
+    env->function = fun;
+    return fun->bytecodes.entry;
+  case t_bclosure:
+    env->function = fun;
+    return fun->bclosure.entry;
+  default:
+    FEinvalid_function(x);
+  }
+  _ecl_unexpected_return();
+}
+
+/* Calling conventions:
+ * Compiled C code calls lisp function supplying #args, and args.
+ *
+ * Linking function performs check_args, gets jmp_buf with _setjmp, then
+ *
+ * if cfun then stores C code address into function link location and transfers
+ * to jmp_buf at cf_self
+
+ * if cclosure then replaces #args with cc_env and calls cc_self otherwise, it
+ * emulates funcall.
+ */
+
+cl_object
+ecl_apply_from_stack_frame(cl_object frame, cl_object x)
+{
+  cl_object *sp = ECL_STACK_FRAME_PTR(frame);
+  cl_index narg = frame->frame.size;
+  cl_env_ptr env = frame->frame.env;
+  cl_objectfn entry = ecl_function_dispatch(env, x);
+  cl_object ret;
+  env->stack_frame = frame;
+  ret = APPLY(narg, entry, sp);
+  env->stack_frame = NULL;
+  return ret;
+}
+
+cl_object
+cl_funcall(cl_narg narg, cl_object function, ...)
+{
+  cl_object output;
+  --narg;
+  {
+    ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame);
+    output = ecl_apply_from_stack_frame(frame, function);
+    ECL_STACK_FRAME_VARARGS_END(frame);
+  }
+  return output;
+}
+
+cl_object *
+_ecl_va_sp(cl_narg narg)
+{
+  return ECL_STACK_FRAME_PTR(ecl_process_env()->stack_frame) + narg;
+}
 
 #if !(ECL_C_ARGUMENTS_LIMIT == 63)
 #error "Please adjust code to the constant!"
@@ -658,4 +733,5 @@ APPLY_fixed(cl_narg n, cl_object (*fn)(), cl_object *x)
   default:
     FEprogram_error("Too many arguments", 0);
   }
+  _ecl_unexpected_return();
 }

src/c/eval.d

@@ -16,127 +16,6 @@
 #include <ecl/ecl-inl.h>
 #include <ecl/internal.h>
 
-cl_object *
-_ecl_va_sp(cl_narg narg)
-{
-  return ECL_STACK_FRAME_PTR(ecl_process_env()->stack_frame) + narg;
-}
-
-/* Calling conventions:
- * Compiled C code calls lisp function supplying #args, and args.
- * Linking function performs check_args, gets jmp_buf with _setjmp, then
- *  if cfun then stores C code address into function link location
- *          and transfers to jmp_buf at cf_self
- *  if cclosure then replaces #args with cc_env and calls cc_self
- *  otherwise, it emulates funcall.
- */
-
-cl_object
-ecl_apply_from_stack_frame(cl_object frame, cl_object x)
-{
-  cl_object *sp = ECL_STACK_FRAME_PTR(frame);
-  cl_index narg = frame->frame.size;
-  cl_object fun = x;
-  cl_object ret;
-  frame->frame.env->stack_frame = frame;
- AGAIN:
-  frame->frame.env->function = fun;
-  if (ecl_unlikely(fun == ECL_NIL))
-    FEundefined_function(x);
-  switch (ecl_t_of(fun)) {
-  case t_cfunfixed:
-    if (ecl_unlikely(narg != (cl_index)fun->cfun.narg))
-      FEwrong_num_arguments(fun);
-    ret = APPLY_fixed(narg, fun->cfunfixed.entry_fixed, sp);
-    break;
-  case t_cfun:
-    ret = APPLY(narg, fun->cfun.entry, sp);
-    break;
-  case t_cclosure:
-    ret = APPLY(narg, fun->cclosure.entry, sp);
-    break;
-  case t_instance:
-    switch (fun->instance.isgf) {
-    case ECL_STANDARD_DISPATCH:
-    case ECL_RESTRICTED_DISPATCH:
-      ret = _ecl_standard_dispatch(frame, fun);
-      break;
-    case ECL_USER_DISPATCH:
-      fun = fun->instance.slots[fun->instance.length - 1];
-      goto AGAIN;
-    case ECL_READER_DISPATCH:
-    case ECL_WRITER_DISPATCH:
-      ret = APPLY(narg, fun->instance.entry, sp);
-      break;
-    default:
-      FEinvalid_function(fun);
-    }
-    break;
-  case t_symbol:
-    if (ecl_unlikely(!ECL_FBOUNDP(fun)))
-      FEundefined_function(fun);
-    fun = ECL_SYM_FUN(fun);
-    goto AGAIN;
-  case t_bytecodes:
-    ret = ecl_interpret(frame, ECL_NIL, fun);
-    break;
-  case t_bclosure:
-    ret = ecl_interpret(frame, fun->bclosure.lex, fun->bclosure.code);
-    break;
-  default:
-    FEinvalid_function(x);
-  }
-  frame->frame.env->stack_frame = NULL; /* for gc's sake */
-  return ret;
-}
-
-cl_objectfn
-ecl_function_dispatch(cl_env_ptr env, cl_object x)
-{
-  cl_object fun = x;
-  if (ecl_unlikely(fun == ECL_NIL))
-    FEundefined_function(x);
-  switch (ecl_t_of(fun)) {
-  case t_cfunfixed:
-    env->function = fun;
-    return fun->cfunfixed.entry;
-  case t_cfun:
-    env->function = fun;
-    return fun->cfun.entry;
-  case t_cclosure:
-    env->function = fun;
-    return fun->cclosure.entry;
-  case t_instance:
-    env->function = fun;
-    return fun->instance.entry;
-  case t_symbol:
-    fun = ECL_SYM_FUN(fun);
-    env->function = fun;
-    return fun->cfun.entry;
-  case t_bytecodes:
-    env->function = fun;
-    return fun->bytecodes.entry;
-  case t_bclosure:
-    env->function = fun;
-    return fun->bclosure.entry;
-  default:
-    FEinvalid_function(x);
-  }
-}
-
-cl_object
-cl_funcall(cl_narg narg, cl_object function, ...)
-{
-  cl_object output;
-  --narg;
-  {
-    ECL_STACK_FRAME_VARARGS_BEGIN(narg, function, frame);
-    output = ecl_apply_from_stack_frame(frame, function);
-    ECL_STACK_FRAME_VARARGS_END(frame);
-  }
-  return output;
-}
-
 @(defun apply (fun lastarg &rest args)
 @ {
     if (narg == 2 && ecl_t_of(lastarg) == t_frame) {