summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/language/cps/arities.scm72
1 files changed, 45 insertions, 27 deletions
diff --git a/module/language/cps/arities.scm b/module/language/cps/arities.scm
index b697ec02e..877750278 100644
--- a/module/language/cps/arities.scm
+++ b/module/language/cps/arities.scm
@@ -58,8 +58,20 @@
(kvoid #f ($kargs () ()
($continue kunspec ($void)))))
($continue kvoid ,exp)))))
- (($ $ktrunc ($ $arity () () #f () #f) kseq)
- ($continue kseq ,exp))
+ (($ $ktrunc arity kargs)
+ ,(rewrite-cps-term arity
+ (($ $arity () () #f () #f)
+ ($continue kargs ,exp))
+ (_
+ ,(let-gensyms (kvoid kvalues void)
+ (build-cps-term
+ ($letk* ((kvalues #f ($kargs ('void) (void)
+ ($continue k
+ ($primcall 'values (void)))))
+ (kvoid #f ($kargs () ()
+ ($continue kvalues
+ ($void)))))
+ ($continue kvoid ,exp)))))))
(($ $kargs () () _)
($continue k ,exp))
(_
@@ -68,31 +80,37 @@
($letk ((k* #f ($kargs () () ($continue k ($void)))))
($continue k* ,exp)))))))
(1
- (let ((drop-result
- (lambda (kseq)
- (let-gensyms (k* drop)
- (build-cps-term
- ($letk ((k* #f ($kargs ('drop) (drop)
- ($continue kseq ($values ())))))
- ($continue k* ,exp)))))))
- (rewrite-cps-term (lookup-cont k conts)
- (($ $ktail)
- ,(rewrite-cps-term exp
- (($var sym)
- ($continue ktail ($primcall 'return (sym))))
- (_
- ,(let-gensyms (k* v)
- (build-cps-term
- ($letk ((k* #f ($kargs (v) (v)
- ($continue k
- ($primcall 'return (v))))))
- ($continue k* ,exp)))))))
- (($ $ktrunc ($ $arity () () #f () #f) kseq)
- ,(drop-result kseq))
- (($ $kargs () () _)
- ,(drop-result k))
- (_
- ($continue k ,exp)))))))
+ (rewrite-cps-term (lookup-cont k conts)
+ (($ $ktail)
+ ,(rewrite-cps-term exp
+ (($var sym)
+ ($continue ktail ($primcall 'return (sym))))
+ (_
+ ,(let-gensyms (k* v)
+ (build-cps-term
+ ($letk ((k* #f ($kargs (v) (v)
+ ($continue k
+ ($primcall 'return (v))))))
+ ($continue k* ,exp)))))))
+ (($ $ktrunc arity kargs)
+ ,(rewrite-cps-term arity
+ (($ $arity (_) () #f () #f)
+ ($continue kargs ,exp))
+ (_
+ ,(let-gensyms (kvalues value)
+ (build-cps-term
+ ($letk ((kvalues #f ($kargs ('value) (value)
+ ($continue k
+ ($primcall 'values (value))))))
+ ($continue kvalues ,exp)))))))
+ (($ $kargs () () _)
+ ,(let-gensyms (k* drop)
+ (build-cps-term
+ ($letk ((k* #f ($kargs ('drop) (drop)
+ ($continue k ($values ())))))
+ ($continue k* ,exp)))))
+ (_
+ ($continue k ,exp))))))
(define (visit-exp k exp)
(rewrite-cps-term exp