mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 22:10:21 +02:00
Elide values primcalls with continuations with rest arguments
* module/language/cps/elide-values.scm (elide-values): Elide values primcalls when continuation has rest arguments.
This commit is contained in:
parent
fa48a2f79a
commit
67b5d06c1a
1 changed files with 26 additions and 4 deletions
|
@ -61,11 +61,33 @@
|
||||||
(($ $ktail)
|
(($ $ktail)
|
||||||
($continue k src ($values vals)))
|
($continue k src ($values vals)))
|
||||||
(($ $ktrunc ($ $arity req () rest () #f) kargs)
|
(($ $ktrunc ($ $arity req () rest () #f) kargs)
|
||||||
,(if (or rest (< (length vals) (length req)))
|
,(cond
|
||||||
term
|
((and (not rest) (= (length vals) (length req)))
|
||||||
(let ((vals (list-head vals (length req))))
|
|
||||||
(build-cps-term
|
(build-cps-term
|
||||||
($continue kargs src ($values vals))))))
|
($continue kargs src ($values vals))))
|
||||||
|
((and rest (>= (length vals) (length req)))
|
||||||
|
(let-gensyms (krest rest)
|
||||||
|
(let ((vals* (append (list-head vals (length req))
|
||||||
|
(list rest))))
|
||||||
|
(build-cps-term
|
||||||
|
($letk ((krest ($kargs ('rest) (rest)
|
||||||
|
($continue kargs src
|
||||||
|
($values vals*)))))
|
||||||
|
,(let lp ((tail (list-tail vals (length req)))
|
||||||
|
(k krest))
|
||||||
|
(match tail
|
||||||
|
(()
|
||||||
|
(build-cps-term ($continue k src
|
||||||
|
($const '()))))
|
||||||
|
((v . tail)
|
||||||
|
(let-gensyms (krest rest)
|
||||||
|
(build-cps-term
|
||||||
|
($letk ((krest ($kargs ('rest) (rest)
|
||||||
|
($continue k src
|
||||||
|
($primcall 'cons
|
||||||
|
(v rest))))))
|
||||||
|
,(lp tail krest))))))))))))
|
||||||
|
(else term)))
|
||||||
(($ $kargs args)
|
(($ $kargs args)
|
||||||
,(if (< (length vals) (length args))
|
,(if (< (length vals) (length args))
|
||||||
term
|
term
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue