From c0ff0ac2275b5311b5f347ab0a8a18530090625e Mon Sep 17 00:00:00 2001
From: BT Templeton <bt@hcoop.net>
Date: Thu, 15 Aug 2013 21:43:51 -0400
Subject: [PATCH] multiple values

* src/eval.c (values_to_list, Fmultiple_value_call, Fvalues)
  (eval_sub_1, Ffuncall1): New functions.
  (eval_sub, Ffuncall): Return only the first value.
---
 src/eval.c | 48 +++++++++++++++++++++++++++++++++++++++++++++---
 src/lisp.h |  1 +
 2 files changed, 46 insertions(+), 3 deletions(-)

diff --git a/src/eval.c b/src/eval.c
index d56a8efe83..3d8573fca9 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -2102,8 +2102,8 @@ set_lisp_eval_depth (void *data)
 
 /* Eval a sub-expression of the current expression (i.e. in the same
    lexical scope).  */
-Lisp_Object
-eval_sub (Lisp_Object form)
+static Lisp_Object
+eval_sub_1 (Lisp_Object form)
 {
   Lisp_Object fun, val, original_fun, original_args;
   Lisp_Object funcar;
@@ -2320,6 +2320,42 @@ eval_sub (Lisp_Object form)
 
   return val;
 }
+
+Lisp_Object
+eval_sub (Lisp_Object form)
+{
+  return scm_c_value_ref (eval_sub_1 (form), 0);
+}
+
+static Lisp_Object
+values_to_list (Lisp_Object values)
+{
+  Lisp_Object list = Qnil;
+  for (int i = scm_c_nvalues (values) - 1; i >= 0; i--)
+    list = Fcons (scm_c_value_ref (values, i), list);
+  return list;
+}
+
+DEFUN ("multiple-value-call", Fmultiple_value_call, Smultiple_value_call,
+       2, UNEVALLED, 0,
+       doc: /* Call with multiple values.
+usage: (multiple-value-call FUNCTION-FORM FORM)  */)
+  (Lisp_Object args)
+{
+  Lisp_Object function_form = eval_sub (XCAR (args));
+  Lisp_Object values = Qnil;
+  while (CONSP (args = XCDR (args)))
+    values = nconc2 (Fnreverse (values_to_list (eval_sub_1 (XCAR (args)))),
+                     values);
+  return apply1 (function_form, Fnreverse (values));
+}
+
+DEFUN ("values", Fvalues, Svalues, 0, MANY, 0,
+       doc: /* Return multiple values. */)
+  (ptrdiff_t nargs, Lisp_Object *args)
+{
+  return scm_c_values (args, nargs);
+}
 
 DEFUN ("apply", Fapply, Sapply, 1, MANY, 0,
        doc: /* Call FUNCTION with our remaining args, using our last arg as list of args.
@@ -2784,7 +2820,7 @@ DEFUN ("functionp", Ffunctionp, Sfunctionp, 1, 1, 0,
   return Qnil;
 }
 
-DEFUN ("funcall", Ffuncall, Sfuncall, 1, MANY, 0,
+DEFUN ("funcall", Ffuncall1, Sfuncall, 1, MANY, 0,
        doc: /* Call first argument as a function, passing remaining arguments to it.
 Return the value that function returns.
 Thus, (funcall 'cons 'x 'y) returns (x . y).
@@ -2940,6 +2976,12 @@ usage: (funcall FUNCTION &rest ARGUMENTS)  */)
   scm_dynwind_end ();
   return val;
 }
+
+Lisp_Object
+Ffuncall (ptrdiff_t nargs, Lisp_Object *args)
+{
+  return scm_c_value_ref (Ffuncall1 (nargs, args), 0);
+}
 
 static Lisp_Object
 apply_lambda (Lisp_Object fun, Lisp_Object args)
diff --git a/src/lisp.h b/src/lisp.h
index edbd167cf5..14d378f04a 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3389,6 +3389,7 @@ extern _Noreturn void xsignal3 (Lisp_Object, Lisp_Object, Lisp_Object,
 				Lisp_Object);
 extern _Noreturn void signal_error (const char *, Lisp_Object);
 extern Lisp_Object eval_sub (Lisp_Object form);
+extern Lisp_Object Ffuncall (ptrdiff_t nargs, Lisp_Object *args);
 extern Lisp_Object apply1 (Lisp_Object, Lisp_Object);
 extern Lisp_Object call0 (Lisp_Object);
 extern Lisp_Object call1 (Lisp_Object, Lisp_Object);
-- 
2.20.1