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

Arities-fixing pass handles incoming $ktrunc with rest args

Browse source 
* module/language/cps/arities.scm (fix-clause-arities): Allow $ktrunc
  arities with rest arguments.
This commit is contained in:
Andy Wingo 2013-12-06 12:04:10 +01:00
parent 67b5d06c1a
commit 7bbfc02959
1 changed files with 36 additions and 21 deletions
Download patch file Download diff file Expand all files Collapse all files

31
module/language/cps/arities.scm
View file

@ -59,11 +59,18 @@
($continue kunspec src ($void)))))
($continue kvoid src ,exp)))))
(($ $ktrunc arity kargs)
,(rewrite-cps-term arity
(($ $arity () () #f () #f)
($continue kargs src ,exp))
,(match arity
(($ $arity () () rest () #f)
(if rest
(let-gensyms (knil)
(build-cps-term
($letk ((knil ($kargs () ()
($continue kargs src ($const '())))))
($continue knil src ,exp))))
(build-cps-term
($continue kargs src ,exp))))
(_
,(let-gensyms (kvoid kvalues void)
(let-gensyms (kvoid kvalues void)
(build-cps-term
($letk* ((kvalues ($kargs ('void) (void)
($continue k src
@ -93,11 +100,19 @@
($primcall 'return (v))))))
($continue k* src ,exp)))))))
(($ $ktrunc arity kargs)
,(rewrite-cps-term arity
(($ $arity (_) () #f () #f)
($continue kargs src ,exp))
,(match arity
(($ $arity (_) () rest () #f)
(if rest
(let-gensyms (kval val nil)
(build-cps-term
($letk ((kval ($kargs ('val) (val)
($letconst (('nil nil '()))
($continue kargs src
($values (val nil)))))))
($continue kval src ,exp))))
(build-cps-term ($continue kargs src ,exp))))
(_
,(let-gensyms (kvalues value)
(let-gensyms (kvalues value)
(build-cps-term
($letk ((kvalues ($kargs ('value) (value)
($continue k src