bug#17634: "Unbound var" compilation error, lambda* & #:optional

[Mark H Weaver]

Josep Portella Florit <address@hidden> writes:

> scheme@(guile-user)> ((lambda* (a #:optional (b (+ a 1))) b) 1)
> While compiling expression:
> ERROR: unbound var a-492
> scheme@(guile-user)> (define f (lambda* (a #:optional (b (+ a 1))) b))
> scheme@(guile-user)> (f 1)
> $2 = 2
> scheme@(guile-user)> ((lambda* (a #:key (b (+ a 1))) b) 1)
> $3 = 2
>
> (Tested on Guile 2.0.11)

The following preliminary patch should fix the problem.  I haven't yet
pushed it because I'd like to add some test cases, and have Andy or
Ludovic review the patch.

     Thanks!
       Mark


>From 4d8002afa0ab851d9878c56c538dd2c8cbd7fc93 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Fri, 30 May 2014 01:27:08 -0400
Subject: [PATCH] peval: Handle optional argument inits that refer to previous
 arguments.

Fixes <http://bugs.gnu.org/17634>.
Reported by Josep Portella Florit <address@hidden>.

* module/language/tree-il/peval.scm (inlined-application): When inlining
  an application whose operator is a lambda expression with optional
  arguments that rely on default initializers, expand into a series of
  nested let expressions, to ensure that previous arguments are in scope
  when the default initializers are evaluated.
---
 module/language/tree-il/peval.scm | 51 +++++++++++++++++++++++++++++----------
 1 file changed, 38 insertions(+), 13 deletions(-)

diff --git a/module/language/tree-il/peval.scm 
b/module/language/tree-il/peval.scm
index bd92edc..04563d6 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1313,24 +1313,49 @@ top-level bindings from ENV and return the resulting 
expression."
                    (nopt (if opt (length opt) 0))
                    (key (source-expression proc)))
               (define (inlined-application)
-                (make-let src
-                          (append req
-                                  (or opt '())
-                                  (if rest (list rest) '()))
-                          gensyms
-                          (if (> nargs (+ nreq nopt))
-                              (append (list-head orig-args (+ nreq nopt))
+                (if (> nargs (+ nreq nopt))
+                    (make-let src
+                              (append req
+                                      (or opt '())
+                                      (list rest))
+                              gensyms
+                              (append (take orig-args (+ nreq nopt))
                                       (list
                                        (make-application
                                         #f
                                         (make-primitive-ref #f 'list)
                                         (drop orig-args (+ nreq nopt)))))
-                              (append orig-args
-                                      (drop inits (- nargs nreq))
-                                      (if rest
-                                          (list (make-const #f '()))
-                                          '())))
-                          body))
+                              body)
+                    (let*-values
+                        (((non-rest-gensyms rest-gensyms)
+                          (split-at gensyms (+ nreq nopt)))
+                         ((provided-gensyms default-gensyms)
+                          (split-at non-rest-gensyms nargs))
+                         ((provided-vars default-vars)
+                          (split-at (append req (or opt '()))
+                                    nargs))
+                         ((rest-vars)
+                          (if rest (list rest) '()))
+                         ((rest-inits)
+                          (if rest
+                              (list (make-const #f '()))
+                              '()))
+                         ((default-inits)
+                          (drop inits (- nargs nreq))))
+                      (make-let src
+                                (append provided-vars rest-vars)
+                                (append provided-gensyms rest-gensyms)
+                                (append orig-args rest-inits)
+                                (fold-right (lambda (var gensym init body)
+                                              (make-let src
+                                                        (list var)
+                                                        (list gensym)
+                                                        (list init)
+                                                        body))
+                                            body
+                                            default-vars
+                                            default-gensyms
+                                            default-inits)))))
 
               (cond
                ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
-- 
1.8.4