diff --git a/TODO b/TODO index 47899bd6..ec64c552 100644 --- a/TODO +++ b/TODO @@ -13,7 +13,7 @@ v "string" v #(v e c t o r) #\CHAR v assq -call-with-values +v call-with-values v char? v length v list @@ -25,7 +25,7 @@ v string v string-append v string? v symbol? -values +v values v vector v vector->list v vector-length diff --git a/mes.c b/mes.c index 19adb534..c2b83d46 100644 --- a/mes.c +++ b/mes.c @@ -42,7 +42,7 @@ #define QUOTE_SUGAR 1 #endif -enum type {CHAR, NUMBER, PAIR, STRING, SYMBOL, VECTOR, +enum type {CHAR, NUMBER, PAIR, STRING, SYMBOL, VALUES, VECTOR, FUNCTION0, FUNCTION1, FUNCTION2, FUNCTION3, FUNCTIONn}; struct scm_t; typedef struct scm_t* (*function0_t) (void); @@ -99,12 +99,14 @@ scm scm_macro = {SYMBOL, "*macro*"}; scm scm_symbol_EOF = {SYMBOL, "EOF"}; scm scm_symbol_EOF2 = {SYMBOL, "EOF2"}; +scm scm_symbol_call_with_values = {SYMBOL, "call-with-values"}; scm scm_symbol_current_module = {SYMBOL, "current-module"}; scm scm_symbol_define = {SYMBOL, "define"}; scm scm_symbol_define_macro = {SYMBOL, "define-macro"}; scm scm_symbol_eval = {SYMBOL, "eval"}; scm scm_symbol_loop2 = {SYMBOL, "loop2"}; scm scm_symbol_set_x = {SYMBOL, "set!"}; +scm scm_symbol_values = {SYMBOL, "values"}; // PRIMITIVES @@ -277,6 +279,8 @@ apply_ (scm *fn, scm *x, scm *a) { if (fn == &scm_symbol_current_module) // FIXME return a; + if (eq_p (fn, &scm_symbol_call_with_values) == &scm_t) + return call (&scm_call_with_values_env, append (x, cons (a, &scm_nil))); if (builtin_p (fn) == &scm_t) return call (fn, x); return apply (eval (fn, a), x, a); @@ -479,6 +483,8 @@ call (scm *fn, scm *x) #endif if (fn->type == FUNCTION0) return fn->function0 (); + if (x->car->type == VALUES) + x = cons (x->car->cdr->car, &scm_nil); if (fn->type == FUNCTION1) return fn->function1 (car (x)); if (fn->type == FUNCTION2) @@ -608,6 +614,23 @@ vector (scm *x/*...*/) // int } #endif +scm * +values (scm *x/*...*/) +{ + scm *v = cons (0, x); + v->type = VALUES; + return v; +} + +scm * +call_with_values_env (scm *producer, scm *consumer, scm *a) +{ + scm *v = apply_ (producer, &scm_nil, a); + if (v->type == VALUES) + v = v->cdr; + return apply_ (consumer, v, a); +} + scm * vector_length (scm *x) { diff --git a/mes.mes b/mes.mes index ee19daf1..c6adec07 100644 --- a/mes.mes +++ b/mes.mes @@ -92,8 +92,10 @@ (cond ((atom? fn) (cond - ((eq? fn 'current-module) ;; FIXME - (c:apply current-module '() a)) + ((eq? fn 'current-module) + (c:apply current-module '() a)) + ((eq? fn 'call-with-values) + (c:apply 'call-with-values x a)) ((builtin? fn) (call fn x)) (#t (apply (eval fn a) x a)))) diff --git a/scm.mes b/scm.mes index 1a9ba322..edbc993b 100755 --- a/scm.mes +++ b/scm.mes @@ -21,6 +21,9 @@ ;; The Maxwell Equations of Software -- John McCarthy page 13 ;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf +(define (defined? x) + (assq x (current-module))) + (define (list . rest) rest) (define (vector . rest) (list->vector rest)) (define assv assq) diff --git a/test.mes b/test.mes index 4482a121..8e2ff1fb 100644 --- a/test.mes +++ b/test.mes @@ -238,4 +238,22 @@ (display (memq 'd '(a b c))) (newline) +(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))) + '()