;;; ECMAScript for Guile
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
#:use-module (srfi srfi-1)
#:export (compile-tree-il))
-(define-syntax ->
- (syntax-rules ()
- ((_ (type arg ...))
- `(type ,arg ...))))
+(define-syntax-rule (-> (type arg ...))
+ `(type ,arg ...))
-(define-syntax @implv
- (syntax-rules ()
- ((_ sym)
- (-> (module-ref '(language ecmascript impl) 'sym #t)))))
+(define-syntax-rule (@implv sym)
+ (-> (@ '(language ecmascript impl) 'sym)))
-(define-syntax @impl
- (syntax-rules ()
- ((_ sym arg ...)
- (-> (apply (@implv sym) arg ...)))))
+(define-syntax-rule (@impl sym arg ...)
+ (-> (call (@implv sym) arg ...)))
(define (empty-lexical-environment)
'())
(define (econs name gensym env)
- (acons name gensym env))
+ (acons name (-> (lexical name gensym)) env))
(define (lookup name env)
(or (assq-ref env name)
(define (compile-tree-il exp env opts)
(values
- (parse-tree-il (comp exp (empty-lexical-environment)))
+ (parse-tree-il
+ (-> (begin (@impl js-init)
+ (comp exp (empty-lexical-environment)))))
env
env))
;; for emacs:
;; (put 'pmatch/source 'scheme-indent-function 1)
-(define-syntax pmatch/source
- (syntax-rules ()
- ((_ x clause ...)
- (let ((x x))
- (let ((res (pmatch x
- clause ...)))
- (let ((loc (location x)))
- (if loc
- (set-source-properties! res (location x))))
- res)))))
+(define-syntax-rule (pmatch/source x clause ...)
+ (let ((x x))
+ (let ((res (pmatch x
+ clause ...)))
+ (let ((loc (location x)))
+ (if loc
+ (set-source-properties! res (location x))))
+ res)))
+
+(define current-return-tag (make-parameter #f))
+
+(define (return expr)
+ (-> (abort (or (current-return-tag) (error "return outside function"))
+ (list expr)
+ (-> (const '())))))
+
+(define (with-return-prompt body-thunk)
+ (let ((tag (gensym "return")))
+ (parameterize ((current-return-tag
+ (-> (lexical 'return tag))))
+ (-> (let '(return) (list tag)
+ (list (-> (primcall 'make-prompt-tag)))
+ (-> (prompt (current-return-tag)
+ (body-thunk)
+ (let ((val (gensym "val")))
+ (-> (lambda-case
+ `(((k val) #f #f #f () (,(gensym) ,val))
+ ,(-> (lexical 'val val)))))))))))))
(define (comp x e)
(let ((l (location x)))
((string ,str)
(-> (const str)))
(this
- (@impl get-this '()))
+ (@impl get-this))
((+ ,a)
- (-> (apply (-> (primitive '+))
- (@impl ->number (comp a e))
- (-> (const 0)))))
+ (-> (call (-> (primitive '+))
+ (@impl ->number (comp a e))
+ (-> (const 0)))))
((- ,a)
- (-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e))))
+ (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
((~ ,a)
(@impl bitwise-not (comp a e)))
((! ,a)
(@impl logical-not (comp a e)))
((+ ,a ,b)
- (-> (apply (-> (primitive '+)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
((- ,a ,b)
- (-> (apply (-> (primitive '-)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
((/ ,a ,b)
- (-> (apply (-> (primitive '/)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
((* ,a ,b)
- (-> (apply (-> (primitive '*)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
((% ,a ,b)
(@impl mod (comp a e) (comp b e)))
((<< ,a ,b)
((>> ,a ,b)
(@impl shift (comp a e) (comp `(- ,b) e)))
((< ,a ,b)
- (-> (apply (-> (primitive '<)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
((<= ,a ,b)
- (-> (apply (-> (primitive '<=)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
((> ,a ,b)
- (-> (apply (-> (primitive '>)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
((>= ,a ,b)
- (-> (apply (-> (primitive '>=)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
((in ,a ,b)
(@impl has-property? (comp a e) (comp b e)))
((== ,a ,b)
- (-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
((!= ,a ,b)
- (-> (apply (-> (primitive 'not))
- (-> (apply (-> (primitive 'equal?))
- (comp a e) (comp b e))))))
+ (-> (call (-> (primitive 'not))
+ (-> (call (-> (primitive 'equal?))
+ (comp a e) (comp b e))))))
((=== ,a ,b)
- (-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e))))
+ (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
((!== ,a ,b)
- (-> (apply (-> (primitive 'not))
- (-> (apply (-> (primitive 'eqv?))
- (comp a e) (comp b e))))))
+ (-> (call (-> (primitive 'not))
+ (-> (call (-> (primitive 'eqv?))
+ (comp a e) (comp b e))))))
((& ,a ,b)
(@impl band (comp a e) (comp b e)))
((^ ,a ,b)
(-> (if (@impl ->boolean (comp test e))
(comp then e)
(comp else e))))
- ((if ,test ,then ,else)
+ ((if ,test ,then)
(-> (if (@impl ->boolean (comp test e))
(comp then e)
(@implv *undefined*))))
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set! (lookup foo e)
- (-> (apply (-> (primitive '+))
- (-> (lexical var var))
- (-> (const 1)))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
((postinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
- (-> (apply (-> (primitive '+))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
((postinc (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (lexical propvar propvar))
- (-> (apply (-> (primitive '+))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))))
+ (-> (call (-> (primitive '+))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))))
((postdec (ref ,foo))
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set (lookup foo e)
- (-> (apply (-> (primitive '-))
- (-> (lexical var var))
- (-> (const 1)))))))))
+ (-> (call (-> (primitive '-))
+ (-> (lexical var var))
+ (-> (const 1)))))))))
((postdec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
- (-> (apply (-> (primitive '-))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))
+ (-> (call (-> (primitive '-))
+ (-> (lexical tmpvar tmpvar))
+ (-> (const 1))))))))))
((postdec (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(let ((v (lookup foo e)))
(-> (begin
(-> (set! v
- (-> (apply (-> (primitive '+))
- v
- (-> (const 1))))))
+ (-> (call (-> (primitive '+))
+ v
+ (-> (const 1))))))
v))))
((preinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
- (begin1 (-> (apply (-> (primitive '+))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput (-> (lexical objvar objvar))
(-> (const prop))
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
- (begin1 (-> (apply (-> (primitive '+))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '+))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(let ((v (lookup foo e)))
(-> (begin
(-> (set! v
- (-> (apply (-> (primitive '-))
+ (-> (call (-> (primitive '-))
v
(-> (const 1))))))
v))))
((predec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
- (begin1 (-> (apply (-> (primitive '-))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (const prop)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
- (begin1 (-> (apply (-> (primitive '-))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (-> (const 1))))
+ (begin1 (-> (call (-> (primitive '-))
+ (@impl pget
+ (-> (lexical objvar objvar))
+ (-> (lexical propvar propvar)))
+ (-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
((ref ,id)
(lookup id e))
((var . ,forms)
- (-> (begin
- (map (lambda (form)
- (pmatch form
- ((,x ,y)
- (-> (define x (comp y e))))
- ((,x)
- (-> (define x (@implv *undefined*))))
- (else (error "bad var form" form))))
- forms))))
+ `(begin
+ ,@(map (lambda (form)
+ (pmatch form
+ ((,x ,y)
+ (-> (define x (comp y e))))
+ ((,x)
+ (-> (define x (@implv *undefined*))))
+ (else (error "bad var form" form))))
+ forms)))
+ ((begin)
+ (-> (void)))
+ ((begin ,form)
+ (comp form e))
((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 ,(map (lambda (x) (@implv *undefined*)) formals) ,syms)
+ ,(with-return-prompt
+ (lambda ()
+ (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 () ())
+ (call ,(@impl pget obj prop) ,@args)))))))
((call (pref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e)
,(-> (const prop))
,@(map (lambda (x) (comp x e)) args))
e))
((call ,proc ,args)
- `(apply ,(comp proc e)
- ,@(map (lambda (x) (comp x e)) args)))
+ `(call ,(comp proc e)
+ ,@(map (lambda (x) (comp x e)) args)))
((return ,expr)
- (-> (apply (-> (primitive 'return))
- (comp expr e))))
+ (return (comp expr e)))
((array . ,args)
- `(apply ,(@implv new-array)
- ,@(map (lambda (x) (comp x e)) args)))
+ `(call ,(@implv new-array)
+ ,@(map (lambda (x) (comp x e)) args)))
((object . ,args)
- (@impl new-object
- (map (lambda (x)
- (pmatch x
- ((,prop ,val)
- (-> (apply (-> (primitive 'cons))
- (-> (const prop))
- (comp val e))))
- (else
- (error "bad prop-val pair" x))))
- args)))
+ `(call ,(@implv new-object)
+ ,@(map (lambda (x)
+ (pmatch x
+ ((,prop ,val)
+ (-> (call (-> (primitive 'cons))
+ (-> (const prop))
+ (comp val e))))
+ (else
+ (error "bad prop-val pair" x))))
+ args)))
((pref ,obj ,prop)
(@impl pget
(comp obj e)
(%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*))))))
- (-> (apply (-> (lexical '%loop %loop)))))))))
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () ())
+ ,(-> (begin
+ (comp statement e)
+ (-> (call (-> (lexical '%continue %continue)))))))))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () ())
+ ,(-> (if (@impl ->boolean (comp test e))
+ (-> (call (-> (lexical '%loop %loop))))
+ (@implv *undefined*)))))))))
+ (-> (call (-> (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*))))))
- (-> (apply (-> (lexical '%continue %continue)))))))))
+ (list (-> (lambda '()
+ (-> (lambda-case
+ `((() #f #f #f () ())
+ ,(-> (if (@impl ->boolean (comp test e))
+ (-> (begin (comp statement e)
+ (-> (call (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
+ (-> (call (-> (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 () ())
+ ,(-> (if (if test
+ (@impl ->boolean (comp test e))
+ (comp 'true e))
+ (-> (begin (comp statement e)
+ (comp (or inc '(begin)) e)
+ (-> (call (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
(-> (begin (comp (or init '(begin)) e)
- (-> (apply (-> (lexical '%continue %continue)))))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))))
((for-in ,var ,object ,statement)
(let ((%enum (gensym "%enum "))
(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*))))))
- (-> (apply (-> (lexical '%continue %continue)))))))))
+ (-> (lambda '()
+ (-> (lambda-case
+ `((() #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)
+ (-> (call (-> (lexical '%continue %continue))))))
+ (@implv *undefined*)))))))))
+ (-> (call (-> (lexical '%continue %continue)))))))))
((block ,x)
(comp x e))
(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)))
(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))))))
HCoop / bpt / guile.git / blobdiff