mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-11 22:31:12 +02:00
Code Activity

Elide values primcalls with continuations with rest arguments

Browse source 
* module/language/cps/elide-values.scm (elide-values): Elide values
  primcalls when continuation has rest arguments.
This commit is contained in:
Andy Wingo 2013-12-06 11:39:04 +01:00
parent fa48a2f79a
commit 67b5d06c1a
1 changed files with 26 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

30
module/language/cps/elide-values.scm
View file

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