summaryrefslogtreecommitdiff
path: root/module/language/ecmascript/compile-tree-il.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-10-17 17:23:09 +0200
committerAndy Wingo <wingo@pobox.com>2009-10-23 15:10:25 +0200
commit7e01997e88c54216678271de36b1c2088377492d (patch)
treeb8f9817abd25a3b2802367b1f115548f8c2202fc /module/language/ecmascript/compile-tree-il.scm
parent8753fd537c4eadf7495f4ba867def99e77246dfc (diff)
downloadguile-7e01997e88c54216678271de36b1c2088377492d.tar.gz
finish support for optional & keyword args; update ecmascript compiler
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump. * libguile/vm-i-system.c (br-if-nargs-ne, br-if-args-lt) (br-if-nargs-gt): New instructions, for use by different lambda cases. (bind-optionals, bind-optionals/shuffle, bind-kwargs): New instructions, for binding optional and keyword arguments. Renumber other ops. * module/language/ecmascript/compile-tree-il.scm (comp, comp-body): Update for new tree-il. Use the new optional argument mechanism instead of emulating it with rest arguments. * module/language/glil/compile-assembly.scm (glil->assembly): Tweaks for optional and keyword argument compilation. * module/language/tree-il.scm (parse-tree-il, unparse-tree-il): Make the else case optional, in the s-expression serialization of tree-il. * module/language/tree-il/compile-glil.scm (flatten): Handle all of the lambda-case capabilities.
Diffstat (limited to 'module/language/ecmascript/compile-tree-il.scm')
-rw-r--r--module/language/ecmascript/compile-tree-il.scm124
1 files changed, 65 insertions, 59 deletions
diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm
index 88f3db76f..d14d7644e 100644
--- a/module/language/ecmascript/compile-tree-il.scm
+++ b/module/language/ecmascript/compile-tree-il.scm
@@ -326,14 +326,20 @@
((begin . ,forms)
`(begin ,@(map (lambda (x) (comp x e)) forms)))
((lambda ,formals ,body)
- (let ((%args (gensym "%args ")))
- (-> (lambda '%args %args '()
- (comp-body (econs '%args %args e) body formals '%args)))))
+ (let ((syms (map (lambda (x)
+ (gensym (string-append (symbol->string x) " ")))
+ formals)))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() ,formals #f #f ,syms #f)
+ ,(comp-body e body formals syms))))))))
((call/this ,obj ,prop . ,args)
(@impl call/this*
obj
- (-> (lambda '() '() '()
- `(apply ,(@impl pget obj prop) ,@args)))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () #f)
+ (apply ,(@impl pget obj prop) ,@args))))))))
((call (pref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e)
,(-> (const prop))
@@ -433,40 +439,46 @@
(%continue (gensym "%continue ")))
(let ((e (econs '%loop %loop (econs '%continue %continue e))))
(-> (letrec '(%loop %continue) (list %loop %continue)
- (list (-> (lambda '() '() '()
- (-> (begin
- (comp statement e)
- (-> (apply (-> (lexical '%continue %continue)))
- )))))
-
- (-> (lambda '() '() '()
- (-> (if (@impl ->boolean (comp test e))
- (-> (apply (-> (lexical '%loop %loop))))
- (@implv *undefined*))))))
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () #f)
+ ,(-> (begin
+ (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue)))))))))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () #f)
+ ,(-> (if (@impl ->boolean (comp test e))
+ (-> (apply (-> (lexical '%loop %loop))))
+ (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%loop %loop)))))))))
((while ,test ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
(-> (letrec '(%continue) (list %continue)
- (list (-> (lambda '() '() '()
- (-> (if (@impl ->boolean (comp test e))
- (-> (begin (comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
- (@implv *undefined*))))))
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () #f)
+ ,(-> (if (@impl ->boolean (comp test e))
+ (-> (begin (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%continue %continue)))))))))
((for ,init ,test ,inc ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
(-> (letrec '(%continue) (list %continue)
- (list (-> (lambda '() '() '()
- (-> (if (if test
- (@impl ->boolean (comp test e))
- (comp 'true e))
- (-> (begin (comp statement e)
- (comp (or inc '(begin)) e)
- (-> (apply (-> (lexical '%continue %continue))))))
- (@implv *undefined*))))))
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () #f)
+ ,(-> (if (if test
+ (@impl ->boolean (comp test e))
+ (comp 'true e))
+ (-> (begin (comp statement e)
+ (comp (or inc '(begin)) e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
(-> (begin (comp (or init '(begin)) e)
(-> (apply (-> (lexical '%continue %continue)))))))))))
@@ -476,18 +488,20 @@
(let ((e (econs '%enum %enum (econs '%continue %continue e))))
(-> (letrec '(%enum %continue) (list %enum %continue)
(list (@impl make-enumerator (comp object e))
- (-> (lambda '() '() '()
- (-> (if (@impl ->boolean
- (@impl pget
- (-> (lexical '%enum %enum))
- (-> (const 'length))))
- (-> (begin
- (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
- ,(-> (const 'pop))))
- e)
- (comp statement e)
- (-> (apply (-> (lexical '%continue %continue))))))
- (@implv *undefined*))))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () #f)
+ (-> (if (@impl ->boolean
+ (@impl pget
+ (-> (lexical '%enum %enum))
+ (-> (const 'length))))
+ (-> (begin
+ (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
+ ,(-> (const 'pop))))
+ e)
+ (comp statement e)
+ (-> (apply (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
(-> (apply (-> (lexical '%continue %continue)))))))))
((block ,x)
@@ -495,18 +509,22 @@
(else
(error "compilation not yet implemented:" x)))))
-(define (comp-body e body formals %args)
+(define (comp-body e body formals formal-syms)
(define (process)
- (let lp ((in body) (out '()) (rvars (reverse formals)))
+ (let lp ((in body) (out '()) (rvars '()))
(pmatch in
(((var (,x) . ,morevars) . ,rest)
(lp `((var . ,morevars) . ,rest)
out
- (if (memq x rvars) rvars (cons x rvars))))
+ (if (or (memq x rvars) (memq x formals))
+ rvars
+ (cons x rvars))))
(((var (,x ,y) . ,morevars) . ,rest)
(lp `((var . ,morevars) . ,rest)
`((= (ref ,x) ,y) . ,out)
- (if (memq x rvars) rvars (cons x rvars))))
+ (if (or (memq x rvars) (memq x formals))
+ rvars
+ (cons x rvars))))
(((var) . ,rest)
(lp rest out rvars))
((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
@@ -532,18 +550,6 @@
(syms (map (lambda (x)
(gensym (string-append (symbol->string x) " ")))
names))
- (e (fold acons e names syms)))
- (let ((%argv (lookup %args e)))
- (let lp ((names names) (syms syms))
- (if (null? names)
- ;; fixme: here check for too many args
- (comp out e)
- (-> (let (list (car names)) (list (car syms))
- (list (-> (if (-> (apply (-> (primitive 'null?)) %argv))
- (-> (@implv *undefined*))
- (-> (let1 (-> (apply (-> (primitive 'car)) %argv))
- (lambda (v)
- (-> (set! %argv
- (-> (apply (-> (primitive 'cdr)) %argv))))
- (-> (lexical v v))))))))
- (lp (cdr names) (cdr syms))))))))))
+ (e (fold econs (fold econs e formals formal-syms) names syms)))
+ (-> (let names syms (map (lambda (x) (->@implv *undefined*)) names)
+ (comp out e))))))