From 4a6d35197939e64720e4467b41cfe8ac0a917ec8 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Thu, 10 Oct 2013 11:19:02 +0200
Subject: [PATCH] Fix peval bug with inlining and optional argument
 initializers

* module/language/tree-il/peval.scm (peval): Fix a bug whereby inlined
  function applications with default argument initializers were putting
  the initializers in the wrong scope.

* test-suite/tests/peval.test ("partial evaluation"): Add a test.
---
 module/language/tree-il/peval.scm | 58 +++++++++++++++++++++----------
 test-suite/tests/peval.test       | 10 +++++-
 2 files changed, 49 insertions(+), 19 deletions(-)

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index 3d350392e..f3c016137 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1350,26 +1350,48 @@ top-level bindings from ENV and return the resulting expression."
             ;; todo: handle the more complex cases
             (let* ((nargs (length orig-args))
                    (nreq (length req))
-                   (nopt (if opt (length opt) 0))
+                   (opt (or opt '()))
+                   (rest (if rest (list rest) '()))
+                   (nopt (length opt))
                    (key (source-expression proc)))
               (define (inlined-call)
-                (make-let src
-                          (append req
-                                  (or opt '())
-                                  (if rest (list rest) '()))
-                          gensyms
-                          (if (> nargs (+ nreq nopt))
-                              (append (list-head orig-args (+ nreq nopt))
-                                      (list
-                                       (make-primcall
-                                        #f 'list
-                                        (drop orig-args (+ nreq nopt)))))
-                              (append orig-args
-                                      (drop inits (- nargs nreq))
-                                      (if rest
-                                          (list (make-const #f '()))
-                                          '())))
-                          body))
+                (let ((req-vals (list-head orig-args nreq))
+                      (opt-vals (let lp ((args (drop orig-args nreq))
+                                         (inits inits)
+                                         (out '()))
+                                  (match inits
+                                    (() (reverse out))
+                                    ((init . inits)
+                                     (match args
+                                       (()
+                                        (lp '() inits (cons init out)))
+                                       ((arg . args)
+                                        (lp args inits (cons arg out))))))))
+                      (rest-vals (cond
+                                  ((> nargs (+ nreq nopt))
+                                   (list (make-primcall
+                                          #f 'list
+                                          (drop orig-args (+ nreq nopt)))))
+                                  (rest (list (make-const #f '())))
+                                  (else '()))))
+                  (if (>= nargs (+ nreq nopt))
+                      (make-let src
+                                (append req opt rest)
+                                gensyms
+                                (append req-vals opt-vals rest-vals)
+                                body)
+                      ;; The required argument values are in the scope
+                      ;; of the optional argument initializers.
+                      (make-let src
+                                (append req rest)
+                                (append (list-head gensyms nreq)
+                                        (last-pair gensyms))
+                                (append req-vals rest-vals)
+                                (make-let src
+                                          opt
+                                          (list-head (drop gensyms nreq) nopt)
+                                          opt-vals
+                                          body)))))
 
               (cond
                ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 270224ecb..0949ddf0e 100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1279,4 +1279,12 @@
   (pass-if-peval
       (call-with-values foo (lambda (x) (bar x)))
     (let (x) (_) ((call (toplevel foo)))
-         (call (toplevel bar) (lexical x _)))))
+         (call (toplevel bar) (lexical x _))))
+
+  (pass-if-peval
+      ((lambda (foo)
+         (define* (bar a #:optional (b (1+ a)))
+           (list a b))
+         (bar 1))
+       1)
+    (primcall list (const 1) (const 2))))