artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

Fix values.

Browse source 
* mes.c (call): Respect any other non-value arguments.
* tests/scm.test (values, values 2, values 3, call-with-values): New test.
This commit is contained in:
Jan Nieuwenhuizen 2016-10-29 16:06:41 +02:00
parent f593a5c9d7
commit 1f511481a3
3 changed files with 11 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
mes.c
View file

@ -499,10 +499,12 @@ call (scm *fn, scm *x)
{ {
if (fn->type == FUNCTION0) if (fn->type == FUNCTION0)
return fn->function0 (); return fn->function0 ();
if (x->car->type == VALUES) if (x != &scm_nil && x->car->type == VALUES)
x = cons (x->car->cdr->car, &scm_nil); x = cons (x->car->cdr->car, x->cdr);
if (fn->type == FUNCTION1) if (fn->type == FUNCTION1)
return fn->function1 (car (x)); 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) if (fn->type == FUNCTION2)
return fn->function2 (car (x), cadr (x)); return fn->function2 (car (x), cadr (x));
if (fn->type == FUNCTION3) if (fn->type == FUNCTION3)

2
module/mes/mes-0.mes
View file

@ -87,7 +87,7 @@
((atom? fn) ((atom? fn)
(cond (cond
((builtin? fn) (call fn x)) ((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) ((eq? fn 'current-module) a)
(#t (apply-env (eval fn a) x a)))) (#t (apply-env (eval fn a) x a))))
((eq? (car fn) 'lambda) ((eq? (car fn) 'lambda)

24
tests/scm.test
View file

@ -99,24 +99,12 @@ exit $?
(pass-if "assq-set! 2" (sequal? (assq-set! '((a . 0)) 'a 1) '((a . 1)))) (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))) (pass-if "assoc" (sequal? (assoc '(a . 0) '((a . 0) (b . 1) ((a . 0) aa))) '((a . 0) aa)))
;; works, but debugging is foo (pass-if "values" (seq? (values 0 1) 0))
;; (cond ((defined? 'loop2) (pass-if "values 2" (seq? ((lambda (x) x) (values 1 2 3)) 1))
;; (display "mes:values broken after loop2") (pass-if "values 3" (seq? 1 ((lambda (x) x) (values 1 2 3))))
;; (newline)) (pass-if "call-with-values" (seq? (call-with-values (lambda () (values 1 2 3))
;; (#t (lambda (a b c) (+ a b c)))
;; (values 0 1) 6))
;; (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 "builtin? car" (builtin? car)) (pass-if "builtin? car" (builtin? car))
(pass-if "builtin? cdr" (builtin? cdr)) (pass-if "builtin? cdr" (builtin? cdr))