From 4b29de9fa0bea548f1e12ca3a73b43f97cd01970 Mon Sep 17 00:00:00 2001
From: Jakub Jankiewicz <jcubic@onet.pl>
Date: Sun, 8 Nov 2020 12:36:34 +0100
Subject: [PATCH] add let-values and let*-values syntax macros

---
 CHANGELOG.md  |  3 +++
 lib/R7RS.scm  | 38 ++++++++++++++++++++++++++++++++++++++
 tests/std.scm | 12 ++++++++++++
 3 files changed, 53 insertions(+)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 7949c354c..cbdbcb99b 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,6 +1,9 @@
 ## 1.0.0-beta.8
+### Features
+* `let-values` and `let*-values` syntax macros
 ### Bugfix
 * fix empty vector literal
+* fix edge case in nested syntax-rules when variable in parent got expanded into identifier
 
 ## 1.0.0-beta.8
 ### Breaking
diff --git a/lib/R7RS.scm b/lib/R7RS.scm
index bc6fb8721..f33d1a098 100644
--- a/lib/R7RS.scm
+++ b/lib/R7RS.scm
@@ -52,6 +52,43 @@
   (typecheck "values-ref" values "values" 1)
   (typecheck "values-ref" n "number" 1)
   (--> values (valueOf) n))
+
+;; -----------------------------------------------------------------------------
+(define-syntax let-values
+  (syntax-rules ()
+    ((_ ()) nil)
+    ((_ () body ...) (begin body ...))
+    ((_ (((x ...) values) ...) body ...)
+     (apply (lambda (x ... ...)
+              body ...)
+            (vector->list (apply %vector-concat (map (lambda (x) ((. x "valueOf")))
+                                                     (list values ...)))))))
+  "(let-values binding body ...)
+
+   The macro work similar to let but variable is list of values and value
+   need to evaluate to result of calling values.")
+
+;; -----------------------------------------------------------------------------
+(define (%vector-concat . args)
+  (if (null? args)
+      #()
+      (begin
+        (typecheck "%vector-concat" (car args) "array")
+        (--> (car args) (concat (apply %vector-concat (cdr args)))))))
+
+;; -----------------------------------------------------------------------------
+(define-syntax let*-values
+  (syntax-rules ()
+    ((_ ()) nil)
+    ((_ () body ...) (begin body ...))
+    ((_ ((bind values) rest ...) . body)
+     (apply (lambda bind
+              (let*-values (rest ...) . body))
+            (vector->list ((. values "valueOf"))))))
+  "(let*-values binding body ...)
+
+   The macro work similar to let* but variable is list of values and value
+   need to evaluate to result of calling values.")
 ;; -----------------------------------------------------------------------------
 ;; R7RS division operators (Gauche Scheme) BSD license
 ;; Copyright (c) 2000-2020  Shiro Kawai  <shiro@acm.org>
@@ -237,3 +274,4 @@
 (define raise throw)
 
 ;; -----------------------------------------------------------------------------
+
diff --git a/tests/std.scm b/tests/std.scm
index 9be719022..c295584a8 100644
--- a/tests/std.scm
+++ b/tests/std.scm
@@ -80,3 +80,15 @@
               "Expecting string, got number in expression `test` (argument 0)")
         (t.is (try (typecheck "test" 10 (list "string" "character") 0) (catch (e) e.message))
               "Expecting string or character, got number in expression `test` (argument 0)")))
+
+(test "std: let-values and let*-values"
+      (lambda (t)
+
+        (let ((a 10) (b 20) (c 30))
+          (let*-values (((a b c) (values 1 2 3)) ((x y z) (values a b c)))
+            (t.is (+ a b c x y z) 12)))
+
+        (let ((a 10) (b 20) (c 30))
+          (let-values (((a b c) (values 1 2 3)) ((x y z) (values a b c)))
+            (t.is (+ x y z) 60)
+            (t.is (+ a b c) 6)))))