Add more of the standard library.

1 files changed, 125 insertions, 0 deletions

diff --git a/lib/scheme/base/40-values.csc b/lib/scheme/base/40-values.csc
new file mode 100644
index 0000000..3a175a5
--- /dev/null
+++ b/lib/scheme/base/40-values.csc
@@ -0,0 +1,125 @@
+(export
+  apply
+  call-with-current-continuation
+  call-with-values
+  call/cc
+  define-values
+  let*-values
+  let-values
+  values)
+(import (only (csc builtins)
+          call-builtin))
+(begin
+
+
+  (define (call-with-current-continuation proc)
+    (call-builtin call-with-current-continuation proc))
+
+
+  (define call/cc call-with-current-continuation)
+
+
+  (define (call-with-values producer consumer)
+    (call-builtin call-with-values producer consumer))
+
+
+  (define (values . things)
+    (call-with-current-continuation
+      (lambda (cont) (apply cont things))))
+
+
+  (define-syntax let-values
+    (syntax-rules ()
+      ((let-values (binding ...) body0 body1 ...)
+        (let-values "bind"
+          (binding ...) () (begin body0 body1 ...)))
+
+      ((let-values "bind" () tmps body)
+        (let tmps body))
+
+      ((let-values "bind" ((b0 e0)
+           binding ...) tmps body)
+        (let-values "mktmp" b0 e0 ()
+           (binding ...) tmps body))
+
+      ((let-values "mktmp" () e0 args
+           bindings tmps body)
+        (call-with-values
+          (lambda () e0)
+          (lambda args
+            (let-values "bind"
+                bindings tmps body))))
+
+      ((let-values "mktmp" (a . b) e0 (arg ...)
+           bindings (tmp ...) body)
+        (let-values "mktmp" b e0 (arg ... x)
+            bindings (tmp ... (a x)) body))
+
+      ((let-values "mktmp" a e0 (arg ...)
+           bindings (tmp ...) body)
+        (call-with-values
+          (lambda () e0)
+          (lambda (arg ... . x)
+            (let-values "bind"
+                bindings (tmp ... (a x)) body))))))
+
+
+  (define-syntax let*-values
+    (syntax-rules ()
+      ((let*-values () body0 body1 ...)
+        (let () body0 body1 ...))
+
+      ((let*-values (binding0 binding1 ...)
+           body0 body1 ...)
+        (let-values (binding0)
+          (let*-values (binding1 ...)
+            body0 body1 ...)))))
+
+
+  (define-syntax define-values
+    (syntax-rules ()
+      ((define-values () expr)
+        (define dummy
+          (call-with-values (lambda () expr)
+                            (lambda args #f))))
+      ((define-values (var) expr)
+        (define var expr))
+      ((define-values (var0 var1 ... varn) expr)
+        (begin
+          (define var0
+            (call-with-values (lambda () expr)
+                              list))
+          (define var1
+            (let ((v (cadr var0)))
+              (set-cdr! var0 (cddr var0))
+              v)) ...
+          (define varn
+            (let ((v (cadr var0)))
+              (set! var0 (car var0))
+              v))))
+      ((define-values (var0 var1 ... . varn) expr)
+        (begin
+          (define var0
+            (call-with-values (lambda () expr)
+                              list))
+          (define var1
+            (let ((v (cadr var0)))
+              (set-cdr! var0 (cddr var0))
+              v)) ...
+          (define varn
+            (let ((v (cdr var0)))
+              (set! var0 (car var0))
+              v))))
+      ((define-values var expr)
+        (define var
+          (call-with-values (lambda () expr)
+                            list)))))
+
+
+  (define (apply proc arg1 . args)
+    (define args*
+      (let loop ((args (cons arg1 args)))
+        (if (null? (cdr args))
+          (car args)
+          (cons (car args) (loop (cdr args))))))
+    (call-builtin apply proc (list->vector args*))))