mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-07 17:52:23 +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 ;; todo: handle the more complex cases
(let* ((nargs (length orig-args)) (let* ((nargs (length orig-args))
(nreq (length req)) (nreq (length req))
(nopt (if opt (length opt) 0)) (opt (or opt '()))
(rest (if rest (list rest) '()))
(nopt (length opt))
(key (source-expression proc))) (key (source-expression proc)))
(define (inlined-call) (define (inlined-call)
(make-let src (let ((req-vals (list-head orig-args nreq))
(append req (opt-vals (let lp ((args (drop orig-args nreq))
(or opt '()) (inits inits)
(if rest (list rest) '())) (out '()))
gensyms (match inits
(if (> nargs (+ nreq nopt)) (() (reverse out))
(append (list-head orig-args (+ nreq nopt)) ((init . inits)
(list (match args
(make-primcall (()
#f 'list (lp '() inits (cons init out)))
(drop orig-args (+ nreq nopt))))) ((arg . args)
(append orig-args (lp args inits (cons arg out))))))))
(drop inits (- nargs nreq)) (rest-vals (cond
(if rest ((> nargs (+ nreq nopt))
(list (make-const #f '())) (list (make-primcall
'()))) #f 'list
body)) (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 (cond
((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt)))) ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))

10
test-suite/tests/peval.test
View file

@ -1279,4 +1279,12 @@
(pass-if-peval (pass-if-peval
(call-with-values foo (lambda (x) (bar x))) (call-with-values foo (lambda (x) (bar x)))
(let (x) (_) ((call (toplevel foo))) (let (x) (_) ((call (toplevel foo)))
(call (toplevel bar) (lexical x _))))) (call (toplevel bar) (lexical x _))))
(pass-if-peval
((lambda (foo)
(define* (bar a #:optional (b (1+ a)))
(list a b))
(bar 1))
1)
(primcall list (const 1) (const 2))))