Added define-values

CHANGELOG.md

@@ -1,5 +1,11 @@
 # Changelog
 
+## 0.11.9 - TBD
+
+Features
+
+- Added `define-values` from R7RS.
+
 ## 0.11.8 - December 30, 2019
 
 Features

scheme/base.sld

@@ -162,6 +162,7 @@
     letrec
     let*-values
     let-values
+    define-values
     begin
     case
     cond
@@ -203,13 +204,6 @@
 ;    rationalize
 ;
 ;    ;; syntax-rules
-;    define-values
-;
-; unclassified TODO's:
-;    import
-;    include
-;    let-syntax
-;    letrec-syntax
 ;;;;
   )
   (inline
@@ -2025,4 +2019,42 @@
                (,(rename 'vector)
                 ,@make-fields))))
   )))))
+
+(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 ... . var-dot) expr)
+    ; (begin
+    ;   (define var0
+    ;     (call-with-values (lambda () expr) list))
+    ;   (define var1
+    ;     (let ((v (cadr var0)))
+    ;       (set-cdr! var0 (cddr var0))
+    ;       v))
+    ;   ...
+    ;   (define var-dot
+    ;     (let ((v (cdr var0)))
+    ;       (set! var0 (car var0))
+    ;       v))))
+    ((define-values var expr)
+     (define var
+       (call-with-values (lambda () expr) list)))))
 ))