Fix values.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sat, 29 Oct 2016 14:06:41 +0000 (16:06 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Mon, 12 Dec 2016 19:33:49 +0000 (20:33 +0100)
* mes.c (call): Respect any other non-value arguments.
* tests/scm.test (values, values 2, values 3, call-with-values): New test.

mes.c
module/mes/mes-0.mes
tests/scm.test

diff --git a/mes.c b/mes.c
index 1e67f26e37e1919f6a7065a5feb8aa86ecfcb3df..e9daf78dc6fd06c68b2406275f5a1c31521684ee 100644 (file)
--- a/mes.c
+++ b/mes.c
@@ -499,10 +499,12 @@ call (scm *fn, scm *x)
 {
   if (fn->type == FUNCTION0)
     return fn->function0 ();
-  if (x->car->type == VALUES)
-    x = cons (x->car->cdr->car, &scm_nil);
+  if (x != &scm_nil && x->car->type == VALUES)
+    x = cons (x->car->cdr->car, x->cdr);
   if (fn->type == FUNCTION1)
     return fn->function1 (car (x));
+  if (x != &scm_nil && x->cdr->car->type == VALUES)
+    x = cons (x->car, cons (x->cdr->car->cdr->car, x->cdr));
   if (fn->type == FUNCTION2)
     return fn->function2 (car (x), cadr (x));
   if (fn->type == FUNCTION3)
index 2fda9f71c60f79a0a1f8709688ed4ebea990348e..2003d0f3f1ac926e58712c5bbda8f87a3544412c 100644 (file)
@@ -87,7 +87,7 @@
    ((atom? fn)
     (cond
      ((builtin? fn) (call fn x))
-     ((eq? fn 'call-with-values) (c:apply-env 'call-with-values x a))
+     ((eq? fn 'call-with-values) (call call-with-values-env (append x (cons a '()))))
      ((eq? fn 'current-module) a)
      (#t (apply-env (eval fn a) x a))))
    ((eq? (car fn) 'lambda)
index 3d33e71eadffab405a4b468420c93c91c230d906..751b14ee2ae0584c9c9ff191116e063bcd303cb5 100755 (executable)
@@ -99,24 +99,12 @@ exit $?
 (pass-if "assq-set! 2" (sequal? (assq-set! '((a . 0)) 'a 1) '((a . 1))))
 (pass-if "assoc" (sequal? (assoc '(a . 0) '((a . 0) (b . 1) ((a . 0) aa))) '((a . 0) aa)))
 
-;; works, but debugging is foo
-;; (cond ((defined? 'loop2)
-;;        (display "mes:values broken after loop2")
-;;        (newline))
-;;       (#t
-;;        (values 0 1)
-;;        (display "(values 0 1): ")
-;;        (display (values 0 1))
-;;        (newline)
-
-;;        (display "call-with-values ==> 6: ")
-;;        (display
-;;         (call-with-values (lambda () (values 1 2 3))
-;;           (lambda (a b c) (+ a b c))))
-;;        (newline)
-;;        (display "call-with-values ==> 1: ")
-;;        (display ((lambda (x) x) (values 1 2 3)))
-;;        (newline)))
+(pass-if "values" (seq? (values 0 1) 0))
+(pass-if "values 2" (seq? ((lambda (x) x) (values 1 2 3)) 1))
+(pass-if "values 3" (seq? 1 ((lambda (x) x) (values 1 2 3))))
+(pass-if "call-with-values" (seq? (call-with-values (lambda () (values 1 2 3))
+                                    (lambda (a b c) (+ a b c)))
+                                  6))
 
 (pass-if "builtin? car" (builtin? car))
 (pass-if "builtin? cdr" (builtin? cdr))