mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-06 23:50:18 +02:00
Code Activity

Fix peval bug with inlining and optional argument initializers

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2013-10-10 11:19:02 +02:00
parent 61c7264fcc
commit 4a6d351979
2 changed files with 49 additions and 19 deletions
Download patch file Download diff file Expand all files Collapse all files

58
module/language/tree-il/peval.scm
View file

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