peval: Handle optional argument inits that refer to previous arguments.

Fixes <http://bugs.gnu.org/17634>.
Reported by Josep Portella Florit <jpf@primfilat.com>.

* 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.

* test-suite/tests/peval.test ("partial evaluation"): Add tests.

diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index bd92edc..7dfbf6f 100644 (file)
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1,6 +1,6 @@
 ;;; Tree-IL partial evaluator
 
-;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc.
+;; Copyright (C) 2011-2014 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -1313,24 +1313,80 @@ 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))
-                                      (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))
+                (cond
+                 ((= nargs (+ nreq nopt))
+                  (make-let src
+                            (append req
+                                    (or opt '())
+                                    (if rest (list rest) '()))
+                            gensyms
+                            (append orig-args
+                                    (if rest
+                                        (list (make-const #f '()))
+                                        '()))
+                            body))
+                 ((> 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)))))
+                            body))
+                 (else
+                  ;; Here we handle the case where nargs < nreq + nopt,
+                  ;; so the rest argument (if any) will be empty, and
+                  ;; there will be optional arguments that rely on their
+                  ;; default initializers.
+                  ;;
+                  ;; The default initializers of optional arguments
+                  ;; may refer to earlier arguments, so in the general
+                  ;; case we must expand into a series of nested let
+                  ;; expressions.
+                  ;;
+                  ;; In the generated code, the outermost let
+                  ;; expression will bind all arguments provided by
+                  ;; the application's argument list, as well as the
+                  ;; empty rest argument, if any.  Each remaining
+                  ;; optional argument that relies on its default
+                  ;; initializer will be bound within an inner let.
+                  ;;
+                  ;; rest-gensyms, rest-vars and rest-inits will have
+                  ;; either 0 or 1 elements.  They are oddly named, but
+                  ;; allow simpler code below.
+                  (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 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))))

diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test
index 5b003d2..2183429 100644 (file)
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@ -1,7 +1,7 @@
 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
 ;;;;
-;;;;   Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2009-2014 Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -410,6 +410,90 @@
      '(2 3))
     (const 7))
 
+  (pass-if-peval
+    ;; Higher order with optional argument (default uses earlier argument).
+    ;; <http://bugs.gnu.org/17634>
+    ((lambda* (f x #:optional (y (+ 3 (car x))))
+       (+ y (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3))
+    (const 12))
+
+  (pass-if-peval
+    ;; Higher order with optional arguments
+    ;; (default uses earlier optional argument).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+       (+ y z (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3))
+    (const 20))
+
+  (pass-if-peval
+    ;; Higher order with optional arguments (one caller-supplied value,
+    ;; one default that uses earlier optional argument).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+       (+ y z (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3)
+    (const 4))
+
+  (pass-if-peval
+    ;; Higher order with optional arguments (caller-supplied values).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+       (+ y z (f (* (car x) (cadr x)))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3
+     17)
+    (const 21))
+
+  (pass-if-peval
+    ;; Higher order with optional and rest arguments (one
+    ;; caller-supplied value, one default that uses earlier optional
+    ;; argument).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+                 #:rest r)
+       (list r (+ y z (f (* (car x) (cadr x))))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3)
+    (apply (primitive list) (const ()) (const 4)))
+
+  (pass-if-peval
+    ;; Higher order with optional and rest arguments
+    ;; (caller-supplied values for optionals).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+                 #:rest r)
+       (list r (+ y z (f (* (car x) (cadr x))))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3
+     17)
+    (apply (primitive list) (const ()) (const 21)))
+
+  (pass-if-peval
+    ;; Higher order with optional and rest arguments
+    ;; (caller-supplied values for optionals and rest).
+    ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+                 #:rest r)
+       (list r (+ y z (f (* (car x) (cadr x))))))
+     (lambda (x)
+       (+ x 1))
+     '(2 3)
+     -3
+     17
+     8
+     3)
+    (let (r) (_) ((apply (primitive list) (const 8) (const 3)))
+      (apply (primitive list) (lexical r _) (const 21))))
+
   (pass-if-peval
     ;; Higher order with optional argument (caller-supplied value).
     ((lambda* (f x #:optional (y 0))