add call-with-values, values.
authorJan Nieuwenhuizen <janneke@gnu.org>
Mon, 11 Jul 2016 17:32:11 +0000 (19:32 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Mon, 11 Jul 2016 17:32:11 +0000 (19:32 +0200)
TODO
mes.c
mes.mes
scm.mes
test.mes

diff --git a/TODO b/TODO
index 47899bd6ea6357520e4ce954d5cae0903aaac127..ec64c5524e957e928656ab9673e1d026e517ad63 100644 (file)
--- a/TODO
+++ b/TODO
@@ -13,7 +13,7 @@ v "string"
 v #(v e c t o r)
 #\CHAR
 v assq
-call-with-values
+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 19adb5344eccd31387555916448126f911108e34..c2b83d464ca3df2010894665651c4f82d446db7a 100644 (file)
--- 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 ee19daf19954f21249575672a64ba7f09c26effb..c6adec07fe16520af0e9106cc340f1cc5b013b6e 100644 (file)
--- a/mes.mes
+++ b/mes.mes
   (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 1a9ba3229f2d194a7455259d743e1fc5795b425b..edbc993bb6e2d6476d008cc7f7d5fd583d5b665e 100755 (executable)
--- 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)
index 4482a121964890b6b819b72c5e32f3914ef94083..8e2ff1fb58ee8a1da86487cac6b7c4ab15536677 100644 (file)
--- a/test.mes
+++ b/test.mes
 (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)))
+
 '()