diff options
author | Mark H Weaver <mhw@netris.org> | 2014-09-28 12:51:11 -0400 |
---|---|---|
committer | Mark H Weaver <mhw@netris.org> | 2014-09-28 23:51:20 -0400 |
commit | 7a71a45cfd6092402d540e9bc5d2432941a8a336 (patch) | |
tree | d2928613b8ed1f48ad293fba13c340d860bfc9e8 /module/language/tree-il/peval.scm | |
parent | ff4af3df238815e434b62693a3c02b8213667ebe (diff) | |
download | guile-7a71a45cfd6092402d540e9bc5d2432941a8a336.tar.gz |
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.
Diffstat (limited to 'module/language/tree-il/peval.scm')
-rw-r--r-- | module/language/tree-il/peval.scm | 94 |
1 files changed, 75 insertions, 19 deletions
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index bd92edc69..7dfbf6fb6 100644 --- 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)))) |