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

[bpt/guile.git] / module / language / tree-il / peval.scm

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))))