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

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

@ -59,19 +59,26 @@
($continue kunspec src ($void))))) ($continue kunspec src ($void)))))
($continue kvoid src ,exp))))) ($continue kvoid src ,exp)))))
(($ $ktrunc arity kargs) (($ $ktrunc arity kargs)
,(rewrite-cps-term arity ,(match arity
(($ $arity () () #f () #f) (($ $arity () () rest () #f)
($continue kargs src ,exp)) (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 (build-cps-term
($letk* ((kvalues ($kargs ('void) (void) ($letk* ((kvalues ($kargs ('void) (void)
($continue k src ($continue k src
($primcall 'values (void))))) ($primcall 'values (void)))))
(kvoid ($kargs () () (kvoid ($kargs () ()
($continue kvalues src ($continue kvalues src
($void))))) ($void)))))
($continue kvoid src ,exp))))))) ($continue kvoid src ,exp)))))))
(($ $kargs () () _) (($ $kargs () () _)
($continue k src ,exp)) ($continue k src ,exp))
(_ (_
@ -93,16 +100,24 @@
($primcall 'return (v)))))) ($primcall 'return (v))))))
($continue k* src ,exp))))))) ($continue k* src ,exp)))))))
(($ $ktrunc arity kargs) (($ $ktrunc arity kargs)
,(rewrite-cps-term arity ,(match arity
(($ $arity (_) () #f () #f) (($ $arity (_) () rest () #f)
($continue kargs src ,exp)) (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 (build-cps-term
($letk ((kvalues ($kargs ('value) (value) ($letk ((kvalues ($kargs ('value) (value)
($continue k src ($continue k src
($primcall 'values (value)))))) ($primcall 'values (value))))))
($continue kvalues src ,exp))))))) ($continue kvalues src ,exp)))))))
(($ $kargs () () _) (($ $kargs () () _)
,(let-gensyms (k* drop) ,(let-gensyms (k* drop)
(build-cps-term (build-cps-term