From: BT Templeton <bt@hcoop.net>
Date: Tue, 20 Aug 2013 17:00:47 +0000 (-0400)
Subject: callable guile procs
X-Git-Url: http://git.hcoop.net/bpt/emacs.git/commitdiff_plain/0a436d7db5235d741467a0c886db3136d524ee02

callable guile procs

* src/eval.c (eval_sub_1, Ffuncall):
* src/lisp.h (functionp): Add support for calling Guile procedures.
---

diff --git a/src/eval.c b/src/eval.c
index bb6d23e01f..e6b39a5064 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -2166,7 +2166,23 @@ eval_sub_1 (Lisp_Object form)
   else if (!NILP (fun) && (fun = SYMBOL_FUNCTION (fun), SYMBOLP (fun)))
     fun = indirect_function (fun);
 
-  if (SUBRP (fun))
+  if (scm_is_true (scm_procedure_p (fun)))
+    {
+      Lisp_Object args_left = original_args;
+      Lisp_Object nargs = Flength (args_left);
+      Lisp_Object *args;
+      size_t argnum = 0;
+
+      SAFE_ALLOCA_LISP (args, XINT (nargs));
+
+      while (! NILP (args_left))
+        {
+          args[argnum++] = eval_sub (Fcar (args_left));
+          args_left = Fcdr (args_left);
+        }
+      val = scm_call_n (fun, args, argnum);
+    }
+  else if (SUBRP (fun))
     {
       Lisp_Object numargs;
       Lisp_Object argvals[8];
@@ -2869,7 +2885,11 @@ usage: (funcall FUNCTION &rest ARGUMENTS)  */)
       && (fun = SYMBOL_FUNCTION (fun), SYMBOLP (fun)))
     fun = indirect_function (fun);
 
-  if (SUBRP (fun))
+  if (scm_is_true (scm_procedure_p (fun)))
+    {
+      val = scm_call_n (fun, args + 1, numargs);
+    }
+  else if (SUBRP (fun))
     {
       if (numargs < XSUBR (fun)->min_args
 	  || (XSUBR (fun)->max_args >= 0 && XSUBR (fun)->max_args < numargs))
diff --git a/src/lisp.h b/src/lisp.h
index 86d20cea0a..3d5e7bed62 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3989,7 +3989,7 @@ functionp (Lisp_Object object)
       return EQ (car, Qlambda) || EQ (car, Qclosure);
     }
   else
-    return false;
+    return scm_is_true (scm_procedure_p (object));
 }
 
 INLINE_HEADER_END