123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577 |
- ;;; ECMAScript for Guile
- ;; Copyright (C) 2009, 2011, 2016 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
- ;;;; License as published by the Free Software Foundation; either
- ;;;; version 3 of the License, or (at your option) any later version.
- ;;;;
- ;;;; This library is distributed in the hope that it will be useful,
- ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- ;;;; Lesser General Public License for more details.
- ;;;;
- ;;;; You should have received a copy of the GNU Lesser General Public
- ;;;; License along with this library; if not, write to the Free Software
- ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
- ;;; Code:
- (define-module (language ecmascript compile-tree-il)
- #:use-module (language tree-il)
- #:use-module (ice-9 receive)
- #:use-module (system base pmatch)
- #:use-module (srfi srfi-1)
- #:export (compile-tree-il))
- (define-syntax-rule (-> (type arg ...))
- `(type ,arg ...))
- (define-syntax-rule (@implv sym)
- (-> (@ '(language ecmascript impl) 'sym)))
- (define-syntax-rule (@impl sym arg ...)
- (-> (call (@implv sym) arg ...)))
- (define (empty-lexical-environment)
- '())
- (define (econs name gensym env)
- (acons name (-> (lexical name gensym)) env))
- (define (lookup name env)
- (or (assq-ref env name)
- (-> (toplevel name))))
- (define (compile-tree-il exp env opts)
- (values
- (parse-tree-il
- (-> (begin (@impl js-init)
- (comp exp (empty-lexical-environment)))))
- env
- env))
- (define (location x)
- (and (pair? x)
- (let ((props (source-properties x)))
- (and (not (null? props))
- props))))
- ;; for emacs:
- ;; (put 'pmatch/source 'scheme-indent-function 1)
- (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 #t
- (current-return-tag)
- (body-thunk)
- (let ((val (gensym "val")))
- (-> (lambda '()
- (-> (lambda-case
- `(((k val) #f #f #f () (,(gensym) ,val))
- ,(-> (lexical 'val val)))))))))))))))
- (define (comp x e)
- (let ((l (location x)))
- (define (let1 what proc)
- (let ((sym (gensym)))
- (-> (let (list sym) (list sym) (list what)
- (proc sym)))))
- (define (begin1 what proc)
- (let1 what (lambda (v)
- (-> (begin (proc v)
- (-> (lexical v v)))))))
- (pmatch/source x
- (null
- ;; FIXME, null doesn't have much relation to EOL...
- (-> (const '())))
- (true
- (-> (const #t)))
- (false
- (-> (const #f)))
- ((number ,num)
- (-> (const num)))
- ((string ,str)
- (-> (const str)))
- (this
- (@impl get-this))
- ((+ ,a)
- (-> (call (-> (primitive '+))
- (@impl ->number (comp a e))
- (-> (const 0)))))
- ((- ,a)
- (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
- ((~ ,a)
- (@impl bitwise-not (comp a e)))
- ((! ,a)
- (@impl logical-not (comp a e)))
- ((+ ,a ,b)
- (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
- ((- ,a ,b)
- (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
- ((/ ,a ,b)
- (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
- ((* ,a ,b)
- (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
- ((% ,a ,b)
- (@impl mod (comp a e) (comp b e)))
- ((<< ,a ,b)
- (@impl shift (comp a e) (comp b e)))
- ((>> ,a ,b)
- (@impl shift (comp a e) (comp `(- ,b) e)))
- ((< ,a ,b)
- (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
- ((<= ,a ,b)
- (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
- ((> ,a ,b)
- (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
- ((>= ,a ,b)
- (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
- ((in ,a ,b)
- (@impl has-property? (comp a e) (comp b e)))
- ((== ,a ,b)
- (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
- ((!= ,a ,b)
- (-> (call (-> (primitive 'not))
- (-> (call (-> (primitive 'equal?))
- (comp a e) (comp b e))))))
- ((=== ,a ,b)
- (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
- ((!== ,a ,b)
- (-> (call (-> (primitive 'not))
- (-> (call (-> (primitive 'eqv?))
- (comp a e) (comp b e))))))
- ((& ,a ,b)
- (@impl band (comp a e) (comp b e)))
- ((^ ,a ,b)
- (@impl bxor (comp a e) (comp b e)))
- ((bor ,a ,b)
- (@impl bior (comp a e) (comp b e)))
- ((and ,a ,b)
- (-> (if (@impl ->boolean (comp a e))
- (comp b e)
- (-> (const #f)))))
- ((or ,a ,b)
- (let1 (comp a e)
- (lambda (v)
- (-> (if (@impl ->boolean (-> (lexical v v)))
- (-> (lexical v v))
- (comp b e))))))
- ((if ,test ,then ,else)
- (-> (if (@impl ->boolean (comp test e))
- (comp then e)
- (comp else e))))
- ((if ,test ,then)
- (-> (if (@impl ->boolean (comp test e))
- (comp then e)
- (@implv *undefined*))))
- ((postinc (ref ,foo))
- (begin1 (comp `(ref ,foo) e)
- (lambda (var)
- (-> (set! (lookup foo e)
- (-> (call (-> (primitive '+))
- (-> (lexical var var))
- (-> (const 1)))))))))
- ((postinc (pref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (begin1 (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (lambda (tmpvar)
- (@impl pput
- (-> (lexical objvar objvar))
- (-> (const prop))
- (-> (call (-> (primitive '+))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))
- ((postinc (aref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (let1 (comp prop e)
- (lambda (propvar)
- (begin1 (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (lambda (tmpvar)
- (@impl pput
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar))
- (-> (call (-> (primitive '+))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))))
- ((postdec (ref ,foo))
- (begin1 (comp `(ref ,foo) e)
- (lambda (var)
- (-> (set (lookup foo e)
- (-> (call (-> (primitive '-))
- (-> (lexical var var))
- (-> (const 1)))))))))
- ((postdec (pref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (begin1 (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (lambda (tmpvar)
- (@impl pput
- (-> (lexical objvar objvar))
- (-> (const prop))
- (-> (call (-> (primitive '-))
- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))
- ((postdec (aref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (let1 (comp prop e)
- (lambda (propvar)
- (begin1 (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (lambda (tmpvar)
- (@impl pput
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar))
- (-> (inline
- '- (-> (lexical tmpvar tmpvar))
- (-> (const 1))))))))))))
- ((preinc (ref ,foo))
- (let ((v (lookup foo e)))
- (-> (begin
- (-> (set! v
- (-> (call (-> (primitive '+))
- v
- (-> (const 1))))))
- v))))
- ((preinc (pref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (begin1 (-> (call (-> (primitive '+))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (-> (const 1))))
- (lambda (tmpvar)
- (@impl pput (-> (lexical objvar objvar))
- (-> (const prop))
- (-> (lexical tmpvar tmpvar))))))))
- ((preinc (aref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (let1 (comp prop e)
- (lambda (propvar)
- (begin1 (-> (call (-> (primitive '+))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (-> (const 1))))
- (lambda (tmpvar)
- (@impl pput
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar))
- (-> (lexical tmpvar tmpvar))))))))))
- ((predec (ref ,foo))
- (let ((v (lookup foo e)))
- (-> (begin
- (-> (set! v
- (-> (call (-> (primitive '-))
- v
- (-> (const 1))))))
- v))))
- ((predec (pref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (begin1 (-> (call (-> (primitive '-))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (const prop)))
- (-> (const 1))))
- (lambda (tmpvar)
- (@impl pput
- (-> (lexical objvar objvar))
- (-> (const prop))
- (-> (lexical tmpvar tmpvar))))))))
- ((predec (aref ,obj ,prop))
- (let1 (comp obj e)
- (lambda (objvar)
- (let1 (comp prop e)
- (lambda (propvar)
- (begin1 (-> (call (-> (primitive '-))
- (@impl pget
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar)))
- (-> (const 1))))
- (lambda (tmpvar)
- (@impl pput
- (-> (lexical objvar objvar))
- (-> (lexical propvar propvar))
- (-> (lexical tmpvar tmpvar))))))))))
- ((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)
- (-> (void)))
- ((begin ,form)
- (comp form e))
- ((begin . ,forms)
- `(begin ,@(map (lambda (x) (comp x e)) forms)))
- ((lambda ,formals ,body)
- (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 '()
- `(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 (aref ,obj ,prop) ,args)
- (comp `(call/this ,(comp obj e)
- ,(comp prop e)
- ,@(map (lambda (x) (comp x e)) args))
- e))
- ((call ,proc ,args)
- `(call ,(comp proc e)
- ,@(map (lambda (x) (comp x e)) args)))
- ((return ,expr)
- (return (comp expr e)))
- ((array . ,args)
- `(call ,(@implv new-array)
- ,@(map (lambda (x) (comp x e)) args)))
- ((object . ,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)
- (-> (const prop))))
- ((aref ,obj ,index)
- (@impl pget
- (comp obj e)
- (comp index e)))
- ((= (ref ,name) ,val)
- (let ((v (lookup name e)))
- (-> (begin
- (-> (set! v (comp val e)))
- v))))
- ((= (pref ,obj ,prop) ,val)
- (@impl pput
- (comp obj e)
- (-> (const prop))
- (comp val e)))
- ((= (aref ,obj ,prop) ,val)
- (@impl pput
- (comp obj e)
- (comp prop e)
- (comp val e)))
- ((+= ,what ,val)
- (comp `(= ,what (+ ,what ,val)) e))
- ((-= ,what ,val)
- (comp `(= ,what (- ,what ,val)) e))
- ((/= ,what ,val)
- (comp `(= ,what (/ ,what ,val)) e))
- ((*= ,what ,val)
- (comp `(= ,what (* ,what ,val)) e))
- ((%= ,what ,val)
- (comp `(= ,what (% ,what ,val)) e))
- ((>>= ,what ,val)
- (comp `(= ,what (>> ,what ,val)) e))
- ((<<= ,what ,val)
- (comp `(= ,what (<< ,what ,val)) e))
- ((>>>= ,what ,val)
- (comp `(= ,what (>>> ,what ,val)) e))
- ((&= ,what ,val)
- (comp `(= ,what (& ,what ,val)) e))
- ((bor= ,what ,val)
- (comp `(= ,what (bor ,what ,val)) e))
- ((^= ,what ,val)
- (comp `(= ,what (^ ,what ,val)) e))
- ((new ,what ,args)
- `(call ,(@implv new)
- ,(comp what e)
- ,@(map (lambda (x) (comp x e)) args)))
- ((delete (pref ,obj ,prop))
- (@impl pdel
- (comp obj e)
- (-> (const prop))))
- ((delete (aref ,obj ,prop))
- (@impl pdel
- (comp obj e)
- (comp prop e)))
- ((void ,expr)
- (-> (begin
- (comp expr e)
- (@implv *undefined*))))
- ((typeof ,expr)
- (@impl typeof
- (comp expr e)))
- ((do ,statement ,test)
- (let ((%loop (gensym "%loop "))
- (%continue (gensym "%continue ")))
- (let ((e (econs '%loop %loop (econs '%continue %continue e))))
- (-> (letrec '(%loop %continue) (list %loop %continue)
- (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 '()
- (-> (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 '()
- (-> (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)
- (-> (call (-> (lexical '%continue %continue)))))))))))
-
- ((for-in ,var ,object ,statement)
- (let ((%enum (gensym "%enum "))
- (%continue (gensym "%continue ")))
- (let ((e (econs '%enum %enum (econs '%continue %continue e))))
- (-> (letrec '(%enum %continue) (list %enum %continue)
- (list (@impl make-enumerator (comp object e))
- (-> (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 formal-syms)
- (define (process)
- (let lp ((in body) (out '()) (rvars '()))
- (pmatch in
- (((var (,x) . ,morevars) . ,rest)
- (lp `((var . ,morevars) . ,rest)
- out
- (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 (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)))
- (lp rest
- (cons x out)
- rvars))
- ((,x . ,rest) (guard (pair? x))
- (receive (sub-out rvars)
- (lp x '() rvars)
- (lp rest
- (cons sub-out out)
- rvars)))
- ((,x . ,rest)
- (lp rest
- (cons x out)
- rvars))
- (()
- (values (reverse! out)
- rvars)))))
- (receive (out rvars)
- (process)
- (let* ((names (reverse rvars))
- (syms (map (lambda (x)
- (gensym (string-append (symbol->string x) " ")))
- names))
- (e (fold econs (fold econs e formals formal-syms) names syms)))
- (-> (let names syms (map (lambda (x) (@implv *undefined*)) names)
- (comp out e))))))
|