summaryrefslogtreecommitdiff
path: root/module/language/cps/compile-js.scm
diff options
context:
space:
mode:
authorIan Price <ianprice90@googlemail.com>2015-06-21 00:45:09 +0100
committerIan Price <ianprice90@googlemail.com>2015-06-22 16:18:12 +0100
commite9f37e6a311c0b9fa1ef78b24cbe901e160db2b5 (patch)
treebb79505ea6bf67baf06aa5d023be17f82f314661 /module/language/cps/compile-js.scm
parenta7b2dfa5810a8e027dfc149c1c173b3023dcc0ec (diff)
downloadguile-e9f37e6a311c0b9fa1ef78b24cbe901e160db2b5.tar.gz
Change function type representation
Diffstat (limited to 'module/language/cps/compile-js.scm')
-rw-r--r--module/language/cps/compile-js.scm87
1 files changed, 37 insertions, 50 deletions
diff --git a/module/language/cps/compile-js.scm b/module/language/cps/compile-js.scm
index c1de2bc6e..e67652eed 100644
--- a/module/language/cps/compile-js.scm
+++ b/module/language/cps/compile-js.scm
@@ -35,61 +35,48 @@
(define (compile-fun fun)
(match fun
(($ $kfun _ _ self ($ $cont tail ($ $ktail)) clause)
- (call-with-values
- (lambda ()
- (extract-clauses self clause))
- (lambda (jump-table clauses)
- (make-function
- (make-id self) (make-kid tail)
- (make-local (map (lambda (clause)
- (compile-clause clause self tail))
- clauses)
- (make-jump-table jump-table))))))))
+ (make-function
+ (make-id self)
+ (make-kid tail)
+ (compile-clauses clause self)))))
-(define (extract-clauses self clause)
- (define (make-params* self req opts rest kw allow-other-keys?)
- (make-params (make-id self)
+(define (compile-clauses clause self)
+ (match clause
+ (($ $cont k ($ $kclause arity body #f))
+ `((,(make-kid k)
+ ,(arity->params arity self)
+ ,(compile-clause arity body self))))
+ (($ $cont k ($ $kclause arity body next))
+ `((,(make-kid k)
+ ,(arity->params arity self)
+ ,(compile-clause arity body self))
+ . ,(compile-clauses next self)))))
+
+(define (arity->params arity self)
+ (match arity
+ (($ $arity req opts rest ((kws names kw-syms) ...) allow-other-keys?)
+ (make-params (make-id self)
(map make-id req)
(map make-id opts)
(and rest (make-id rest))
- (map make-id kw)
- allow-other-keys?))
- (let loop ((clause clause) (specs '()) (clauses '()))
- (match clause
- (($ $cont k ($ $kclause ($ $arity req opts rest kw allow-other-keys?) _ #f))
- (values (reverse (acons (make-params* self req opts rest kw allow-other-keys?)
- (make-kid k)
- specs))
- (reverse (cons clause clauses))))
- (($ $cont k ($ $kclause ($ $arity req opts rest kw allow-other-keys?) _ alternate))
- (loop alternate
- (acons (make-params* self req opts rest kw allow-other-keys?)
- (make-kid k)
- specs)
- (cons clause clauses))))))
-
-(define (compile-clause clause self tail)
- (match clause
- (($ $cont k ($ $kclause ($ $arity req opt rest ((_ _ kw-syms) ...) _) body _))
- (make-var
- (make-kid k)
- (make-continuation
- (append (list (make-id self))
- (map make-id req)
- (map make-id opt)
- (map make-id kw-syms)
- (if rest (list (make-id rest)) '()))
- (match body
- (($ $cont k ($ $kargs () () exp))
- (compile-term exp))
- (($ $cont k _)
- (make-local (list (compile-cont body))
- (make-continue
- (make-kid k)
- (map make-id (append req opt kw-syms (if rest (list rest) '()))))))))))))
+ (map (lambda (kw name kw-sym)
+ (list kw (make-id name) (make-id kw-sym)))
+ kws
+ names
+ kw-syms)
+ allow-other-keys?))))
-(define (not-supported msg clause)
- (error 'not-supported msg clause))
+(define (compile-clause arity body self)
+ (match arity
+ (($ $arity req opt rest ((_ _ kw-syms) ...) _)
+ (let ((ids (map make-id
+ (append req opt kw-syms (if rest (list rest) '())))))
+ (make-continuation
+ (cons (make-id self) ids)
+ (match body
+ (($ $cont k _)
+ (make-local (list (compile-cont body))
+ (make-continue (make-kid k) ids)))))))))
(define (compile-term term)
(match term