Fix bug #63454.

Add optimizations for mixed single and multiple-value bindings in let-values.

diff --git a/src/runtime/mit-macros.scm b/src/runtime/mit-macros.scm
index b595b7eb36d41111b1f7a1761faf554a2870c28f..a5378e26759063979789505ec0f0272ffba9a47a 100644 (file)
--- a/src/runtime/mit-macros.scm
+++ b/src/runtime/mit-macros.scm
@@ -179,32 +179,64 @@ USA.
        (lambda (bindings body-forms)
         (let ((body (apply scons-begin body-forms)))
           (case (length bindings)
-            ((0)
-             (scons-let '() body))
+            ((0) (scons-let '() body))
             ((1)
-             (scons-cwv (car (car bindings))
-                        (scons-lambda '() (cadr (car bindings)))
-                        body))
+             (let ((b (car bindings)))
+               (if (bvl-single? (car b))
+                   (scons-let (list (list (caar b) (cadr b)))
+                     body)
+                   (scons-cwv (car b)
+                              (scons-lambda '() (cadr b))
+                              body))))
             (else
              (let-values-multi bindings body)))))))))
 
 (define (let-values-multi bindings body)
-  (let ((temps
-        (map (lambda (index)
-               (new-identifier (symbol 'temp- index)))
-             (iota (length bindings))))
-       (thunks
-        (map (lambda (binding)
-               (scons-lambda () (cadr binding)))
-             bindings)))
-    (scons-let (map list temps thunks)
-      (let loop ((bvls (map car bindings)) (temps temps))
-       (if (pair? bvls)
-           (scons-cwv (car bvls)
-                      (car temps)
-                      (loop (cdr bvls) (cdr temps)))
-           body)))))
+  (receive (single multi)
+      (partition (lambda (b)
+                  (bvl-single? (car b)))
+                bindings)
+    (if (null? multi)
+       (scons-let (map (lambda (b)
+                         (list (caar b) (cadr b)))
+                       single)
+         body)
+       (let ((stemps (map make-temp single))
+             (mtemps (map make-temp multi)))
+         (scons-let
+             (append (map (lambda (b t)
+                            (list t (cadr b)))
+                          single
+                          stemps)
+                     (map (lambda (b t)
+                            (list t (scons-lambda '() (cadr b))))
+                          multi
+                          mtemps))
+           (fold (lambda (b t expr)
+                   (scons-cwv (car b) t expr))
+                 (if (null? single)
+                     body
+                     (scons-let (map (lambda (b t)
+                                       (list (caar b) t))
+                                     single
+                                     stemps)
+                       body))
+                 multi
+                 mtemps))))))
+
+(define (bvl-single? bvl)
+  (and (pair? bvl)
+       (null? (cdr bvl))))
+
+(define (make-temp x)
+  (declare (ignore x))
+  (generate-uninterned-symbol))
 
+(define (scons-cwv bvl thunk body)
+  (scons-call (scons-close 'call-with-values)
+             thunk
+             (scons-lambda bvl body)))
+\f
 (define-syntax $let*-values
   (syntax-rules ()
     ((let*-values () body0 body1 ...)
@@ -225,11 +257,6 @@ USA.
                    (scons-lambda '() expr)
                    (apply scons-begin body-forms)))))))
 
-(define (scons-cwv bvl thunk body)
-  (scons-call (scons-close 'call-with-values)
-             thunk
-             (scons-lambda bvl body)))
-\f
 ;;; SRFI 2: and-let*
 
 ;;; The SRFI document is a little unclear about the semantics, imposes

diff --git a/tests/runtime/test-syntax.scm b/tests/runtime/test-syntax.scm
index 8975d5a254567e9fb5d38dbcc59a17ad555a6a4e..4ffe37dc968fded7c8c61b8fec34b018703d56ed 100644 (file)
--- a/tests/runtime/test-syntax.scm
+++ b/tests/runtime/test-syntax.scm
@@ -29,19 +29,22 @@ USA.
 
 (declare (usual-integrations))
 \f
+(define (expand-expr expr)
+  (unsyntax (syntax expr test-environment)))
+
 (define test-environment
   (the-environment))
 
 (define-test 'local-define-syntax/syntax
   (lambda ()
     (assert-matches
-     (unsyntax
-      (syntax '(let ()
-                 (define-syntax test
-                   (syntax-rules () ((test) (lambda (y) y))))
-                 (list ((test) 1) ((test) 2)))
-              test-environment))
-     '(let () (list (let ((?y1 1)) ?y1) (let ((?y2 2)) ?y2))))))
+     (expand-expr '(let ()
+                    (define-syntax test
+                      (syntax-rules () ((test) (lambda (y) y))))
+                    (list ((test) 1) ((test) 2))))
+     '(let ()
+       (list (let ((?y1 1)) ?y1)
+             (let ((?y2 2)) ?y2))))))
 
 (define-test 'local-define-syntax/eval
   (lambda ()
@@ -90,50 +93,44 @@ USA.
 (define-test 'quoted-macro-name
   (lambda ()
     (assert-equal
-     (unsyntax
-      (syntax '(let ()
-                 (define-syntax foo
-                   (er-macro-transformer
-                    (lambda (f r c)
-                      `(,(r 'quote) foo))))
-                 (foo))
-              test-environment))
+     (expand-expr '(let ()
+                    (define-syntax foo
+                      (er-macro-transformer
+                       (lambda (f r c)
+                         `(,(r 'quote) foo))))
+                    (foo)))
      '(let () 'foo))))
-
+\f
 (define-test 'ellipsis-ellipsis
   (lambda ()
     (assert-equal
-     (unsyntax
-      (syntax '(let ()
-                (define-syntax flatten
-                  (syntax-rules ()
-                    ((flatten f (a ...) ...)
-                     (f a ... ...))))
-                (flatten list (0 1) (2 3) (4)))
-             test-environment))
+     (expand-expr '(let ()
+                    (define-syntax flatten
+                      (syntax-rules ()
+                        ((flatten f (a ...) ...)
+                         (f a ... ...))))
+                    (flatten list (0 1) (2 3) (4))))
      '(let () (list 0 1 2 3 4)))))
 
 (define-test 'bug-57785
   (lambda ()
     (assert-matches
-     (unsyntax
-      (syntax '(lambda ()
-
-                (define-syntax bar
-                   (sc-macro-transformer
-                    (lambda (exp env)
-                      `(let ((,(cadr exp)
-                              ,(close-syntax (cadr exp) env)))
-                        (list ,(close-syntax (cadr exp) env)
-                               'x)))))
-
-                (define-syntax bat
-                   (syntax-rules ()
-                     ((_ body ...)
-                      ((lambda (md) (bar md)) 'quux))))
-
-                (bat x))
-              test-environment))
+     (expand-expr '(lambda ()
+
+                    (define-syntax bar
+                       (sc-macro-transformer
+                       (lambda (exp env)
+                         `(let ((,(cadr exp)
+                                 ,(close-syntax (cadr exp) env)))
+                            (list ,(close-syntax (cadr exp) env)
+                                  'x)))))
+
+                    (define-syntax bat
+                       (syntax-rules ()
+                        ((_ body ...)
+                         ((lambda (md) (bar md)) 'quux))))
+
+                    (bat x)))
      '(lambda ()
        (let ((?x1 'quux))
          (let ((?x2 ?x1))
@@ -142,73 +139,106 @@ USA.
 (define-test 'bug-57793
   (lambda ()
     (assert-equal
-     (unsyntax
-      (syntax '(lambda ()
-
-                (define-syntax foo
-                  (syntax-rules ()
-                    ((_ (x y z))
-                     (letrec-syntax
-                         ((bar (syntax-rules (q)
-                                 ((_ q w)
-                                  '()))))
-                       (bar y z)))))
-
-                (foo (x1 q z1)))
-              test-environment))
+     (expand-expr '(lambda ()
+
+                    (define-syntax foo
+                      (syntax-rules ()
+                        ((_ (x y z))
+                         (letrec-syntax
+                             ((bar (syntax-rules (q)
+                                     ((_ q w)
+                                      '()))))
+                           (bar y z)))))
+
+                    (foo (x1 q z1))))
      '(lambda ()
        '()))))
 
 (define-test 'bug-57833
   (lambda ()
     (assert-equal
-     (unsyntax
-      (syntax '(lambda ()
-                (define-syntax foo
-                  (syntax-rules ()
-                    ((_ xy)
-                     (letrec-syntax
-                         ((bar1 (syntax-rules ()
-                                  ((_ (else* destination))
-                                   (destination))))
-                          (bar2 (syntax-rules ()
-                                  ((_ z)
-                                   (bar1 z)))))
-                       (bar2 xy)))))
-                (foo (else* start)))
-             test-environment))
+     (expand-expr '(lambda ()
+                    (define-syntax foo
+                      (syntax-rules ()
+                        ((_ xy)
+                         (letrec-syntax
+                             ((bar1 (syntax-rules ()
+                                      ((_ (else* destination))
+                                       (destination))))
+                              (bar2 (syntax-rules ()
+                                      ((_ z)
+                                       (bar1 z)))))
+                           (bar2 xy)))))
+                    (foo (else* start))))
      '(lambda ()
        (start)))))
-
+\f
 (define-test 'bug-63438
   (lambda ()
     (assert-matches
-     (unsyntax
-      (syntax '(let ()
-                (define-syntax foo
-                  (syntax-rules ()
-                    ((foo 0)
-                     (foo 1 x))
-                    ((foo 1 y)
-                     (lambda (x y)
-                       (list (list x y)
-                             (lambda (y) (list x y)))))))
-                (foo 0))
-             test-environment))
+     (expand-expr '(let ()
+                    (define-syntax foo
+                      (syntax-rules ()
+                        ((foo 0)
+                         (foo 1 x))
+                        ((foo 1 y)
+                         (lambda (x y)
+                           (list (list x y)
+                                 (lambda (y) (list x y)))))))
+                    (foo 0)))
      '(let ()
        (lambda (?x1 ?x2)
          (list (list ?x1 ?x2) (lambda (?x3) (list ?x1 ?x3))))))
     (assert-matches
-     (unsyntax
-      (syntax '(let ((.x.1-0 123))
-                (define-syntax foo
-                   (syntax-rules ()
-                     ((foo y) (lambda (x) y))))
-                ((foo .x.1-0) 456))
-             test-environment))
+     (expand-expr '(let ((.x.1-0 123))
+                    (define-syntax foo
+                       (syntax-rules ()
+                        ((foo y) (lambda (x) y))))
+                    ((foo .x.1-0) 456)))
      '(let ((.x.1-0 123))
        (let ((?x1 456))
          .x.1-0)))))
+
+(define-test 'let-values
+  (lambda ()
+    (assert-equal
+     (expand-expr '(let-values () unspecific))
+     '(let () unspecific))
+    (assert-equal
+     (expand-expr '(let-values (((a) foo)) unspecific))
+     '(let ((a foo)) unspecific))
+    (assert-equal
+     (expand-expr '(let-values (((a) foo)
+                               ((b) bar))
+                    unspecific))
+     '(let ((a foo)
+           (b bar))
+       unspecific))
+    (assert-equal
+     (expand-expr '(let-values ((() foo)) unspecific))
+     '(call-with-values (lambda () foo)
+       (lambda () unspecific)))
+    (assert-equal
+     (expand-expr '(let-values (((a b) foo)) unspecific))
+     '(call-with-values (lambda () foo)
+       (lambda (a b) unspecific)))
+    (assert-matches
+     (expand-expr '(let-values (((a) foo) ((b c) bar)) unspecific))
+     '(let ((?x1 foo)
+           (?x2 (lambda () bar)))
+       (call-with-values ?x2
+         (lambda (b c)
+           (let ((a ?x1))
+             unspecific)))))
+    (assert-matches
+     (expand-expr '(let-values (((a b) foo) ((c d) bar)) unspecific))
+     '(let ((?x1 (lambda () foo))
+           (?x2 (lambda () bar)))
+       (call-with-values ?x2
+         (lambda (c d)
+           (call-with-values ?x1
+             (lambda (a b)
+               unspecific))))))))
 \f
 ;;;; Tests of syntax-rules, from Larceny:
 
@@ -274,7 +304,7 @@ USA.
 
     (assert-eqv (ellipses-as-literal ...) 'under)
     (assert-eqv (ellipses-as-literal 6) 'other)))
-
+\f
 (define-test 'override-ellipsis
   (lambda ()