module/language/ecmascript/compile-tree-il.scm

   1 ;;; ECMAScript for Guile
   2
   3 ;; Copyright (C) 2009, 2011 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (language ecmascript compile-tree-il)
  22   #:use-module (language tree-il)
  23   #:use-module (ice-9 receive)
  24   #:use-module (system base pmatch)
  25   #:use-module (srfi srfi-1)
  26   #:export (compile-tree-il))
  27
  28 (define-syntax-rule (-> (type arg ...))
  29   `(type ,arg ...))
  30
  31 (define-syntax-rule (@implv sym)
  32   (-> (@ '(language ecmascript impl) 'sym)))
  33
  34 (define-syntax-rule (@impl sym arg ...)
  35   (-> (call (@implv sym) arg ...)))
  36
  37 (define (empty-lexical-environment)
  38   '())
  39
  40 (define (econs name gensym env)
  41   (acons name (-> (lexical name gensym)) env))
  42
  43 (define (lookup name env)
  44   (or (assq-ref env name)
  45       (-> (toplevel name))))
  46
  47 (define (compile-tree-il exp env opts)
  48   (values
  49    (parse-tree-il
  50     (-> (begin (@impl js-init)
  51                (comp exp (empty-lexical-environment)))))
  52    env
  53    env))
  54
  55 (define (location x)
  56   (and (pair? x)
  57        (let ((props (source-properties x)))
  58          (and (not (null? props))
  59               props))))
  60
  61 ;; for emacs:
  62 ;; (put 'pmatch/source 'scheme-indent-function 1)
  63
  64 (define-syntax-rule (pmatch/source x clause ...)
  65   (let ((x x))
  66     (let ((res (pmatch x
  67                  clause ...)))
  68       (let ((loc (location x)))
  69         (if loc
  70             (set-source-properties! res (location x))))
  71       res)))
  72
  73 (define (comp x e)
  74   (let ((l (location x)))
  75     (define (let1 what proc)
  76       (let ((sym (gensym)))
  77         (-> (let (list sym) (list sym) (list what)
  78                  (proc sym)))))
  79     (define (begin1 what proc)
  80       (let1 what (lambda (v)
  81                    (-> (begin (proc v)
  82                               (-> (lexical v v)))))))
  83     (pmatch/source x
  84       (null
  85        ;; FIXME, null doesn't have much relation to EOL...
  86        (-> (const '())))
  87       (true
  88        (-> (const #t)))
  89       (false
  90        (-> (const #f)))
  91       ((number ,num)
  92        (-> (const num)))
  93       ((string ,str)
  94        (-> (const str)))
  95       (this
  96        (@impl get-this))
  97       ((+ ,a)
  98        (-> (call (-> (primitive '+))
  99                  (@impl ->number (comp a e))
 100                  (-> (const 0)))))
 101       ((- ,a)
 102        (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
 103       ((~ ,a)
 104        (@impl bitwise-not (comp a e)))
 105       ((! ,a)
 106        (@impl logical-not (comp a e)))
 107       ((+ ,a ,b)
 108        (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
 109       ((- ,a ,b)
 110        (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
 111       ((/ ,a ,b)
 112        (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
 113       ((* ,a ,b)
 114        (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
 115       ((% ,a ,b)
 116        (@impl mod (comp a e) (comp b e)))
 117       ((<< ,a ,b)
 118        (@impl shift (comp a e) (comp b e)))
 119       ((>> ,a ,b)
 120        (@impl shift (comp a e) (comp `(- ,b) e)))
 121       ((< ,a ,b)
 122        (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
 123       ((<= ,a ,b)
 124        (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
 125       ((> ,a ,b)
 126        (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
 127       ((>= ,a ,b)
 128        (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
 129       ((in ,a ,b)
 130        (@impl has-property? (comp a e) (comp b e)))
 131       ((== ,a ,b)
 132        (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
 133       ((!= ,a ,b)
 134        (-> (call (-> (primitive 'not))
 135                  (-> (call (-> (primitive 'equal?))
 136                            (comp a e) (comp b e))))))
 137       ((=== ,a ,b)
 138        (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
 139       ((!== ,a ,b)
 140        (-> (call (-> (primitive 'not))
 141                  (-> (call (-> (primitive 'eqv?))
 142                            (comp a e) (comp b e))))))
 143       ((& ,a ,b)
 144        (@impl band (comp a e) (comp b e)))
 145       ((^ ,a ,b)
 146        (@impl bxor (comp a e) (comp b e)))
 147       ((bor ,a ,b)
 148        (@impl bior (comp a e) (comp b e)))
 149       ((and ,a ,b)
 150        (-> (if (@impl ->boolean (comp a e))
 151                (comp b e)
 152                (-> (const #f)))))
 153       ((or ,a ,b)
 154        (let1 (comp a e)
 155              (lambda (v)
 156                (-> (if (@impl ->boolean (-> (lexical v v)))
 157                        (-> (lexical v v))
 158                        (comp b e))))))
 159       ((if ,test ,then ,else)
 160        (-> (if (@impl ->boolean (comp test e))
 161                (comp then e)
 162                (comp else e))))
 163       ((if ,test ,then)
 164        (-> (if (@impl ->boolean (comp test e))
 165                (comp then e)
 166                (@implv *undefined*))))
 167       ((postinc (ref ,foo))
 168        (begin1 (comp `(ref ,foo) e)
 169                (lambda (var)
 170                  (-> (set! (lookup foo e)
 171                            (-> (call (-> (primitive '+))
 172                                      (-> (lexical var var))
 173                                      (-> (const 1)))))))))
 174       ((postinc (pref ,obj ,prop))
 175        (let1 (comp obj e)
 176              (lambda (objvar)
 177                (begin1 (@impl pget
 178                               (-> (lexical objvar objvar))
 179                               (-> (const prop)))
 180                        (lambda (tmpvar)
 181                          (@impl pput
 182                                 (-> (lexical objvar objvar))
 183                                 (-> (const prop))
 184                                 (-> (call (-> (primitive '+))
 185                                           (-> (lexical tmpvar tmpvar))
 186                                           (-> (const 1))))))))))
 187       ((postinc (aref ,obj ,prop))
 188        (let1 (comp obj e)
 189              (lambda (objvar)
 190                (let1 (comp prop e)
 191                      (lambda (propvar)
 192                        (begin1 (@impl pget
 193                                       (-> (lexical objvar objvar))
 194                                       (-> (lexical propvar propvar)))
 195                                (lambda (tmpvar)
 196                                  (@impl pput
 197                                         (-> (lexical objvar objvar))
 198                                         (-> (lexical propvar propvar))
 199                                         (-> (call (-> (primitive '+))
 200                                                   (-> (lexical tmpvar tmpvar))
 201                                                   (-> (const 1))))))))))))
 202       ((postdec (ref ,foo))
 203        (begin1 (comp `(ref ,foo) e)
 204                (lambda (var)
 205                  (-> (set (lookup foo e)
 206                           (-> (call (-> (primitive '-))
 207                                     (-> (lexical var var))
 208                                     (-> (const 1)))))))))
 209       ((postdec (pref ,obj ,prop))
 210        (let1 (comp obj e)
 211              (lambda (objvar)
 212                (begin1 (@impl pget
 213                               (-> (lexical objvar objvar))
 214                               (-> (const prop)))
 215                        (lambda (tmpvar)
 216                          (@impl pput
 217                                 (-> (lexical objvar objvar))
 218                                 (-> (const prop))
 219                                 (-> (call (-> (primitive '-))
 220                                           (-> (lexical tmpvar tmpvar))
 221                                           (-> (const 1))))))))))
 222       ((postdec (aref ,obj ,prop))
 223        (let1 (comp obj e)
 224              (lambda (objvar)
 225                (let1 (comp prop e)
 226                      (lambda (propvar)
 227                        (begin1 (@impl pget
 228                                       (-> (lexical objvar objvar))
 229                                       (-> (lexical propvar propvar)))
 230                                (lambda (tmpvar)
 231                                  (@impl pput
 232                                         (-> (lexical objvar objvar))
 233                                         (-> (lexical propvar propvar))
 234                                         (-> (inline
 235                                              '- (-> (lexical tmpvar tmpvar))
 236                                              (-> (const 1))))))))))))
 237       ((preinc (ref ,foo))
 238        (let ((v (lookup foo e)))
 239          (-> (begin
 240                (-> (set! v
 241                          (-> (call (-> (primitive '+))
 242                                    v
 243                                    (-> (const 1))))))
 244                v))))
 245       ((preinc (pref ,obj ,prop))
 246        (let1 (comp obj e)
 247              (lambda (objvar)
 248                (begin1 (-> (call (-> (primitive '+))
 249                                  (@impl pget
 250                                         (-> (lexical objvar objvar))
 251                                         (-> (const prop)))
 252                                  (-> (const 1))))
 253                        (lambda (tmpvar)
 254                          (@impl pput (-> (lexical objvar objvar))
 255                                 (-> (const prop))
 256                                 (-> (lexical tmpvar tmpvar))))))))
 257       ((preinc (aref ,obj ,prop))
 258        (let1 (comp obj e)
 259              (lambda (objvar)
 260                (let1 (comp prop e)
 261                      (lambda (propvar)
 262                        (begin1 (-> (call (-> (primitive '+))
 263                                          (@impl pget
 264                                                 (-> (lexical objvar objvar))
 265                                                 (-> (lexical propvar propvar)))
 266                                          (-> (const 1))))
 267                                (lambda (tmpvar)
 268                                  (@impl pput
 269                                         (-> (lexical objvar objvar))
 270                                         (-> (lexical propvar propvar))
 271                                         (-> (lexical tmpvar tmpvar))))))))))
 272       ((predec (ref ,foo))
 273        (let ((v (lookup foo e)))
 274          (-> (begin
 275                (-> (set! v
 276                          (-> (call (-> (primitive '-))
 277                                    v
 278                                    (-> (const 1))))))
 279                v))))
 280       ((predec (pref ,obj ,prop))
 281        (let1 (comp obj e)
 282              (lambda (objvar)
 283                (begin1 (-> (call (-> (primitive '-))
 284                                  (@impl pget
 285                                         (-> (lexical objvar objvar))
 286                                         (-> (const prop)))
 287                                  (-> (const 1))))
 288                        (lambda (tmpvar)
 289                          (@impl pput
 290                                 (-> (lexical objvar objvar))
 291                                 (-> (const prop))
 292                                 (-> (lexical tmpvar tmpvar))))))))
 293       ((predec (aref ,obj ,prop))
 294        (let1 (comp obj e)
 295              (lambda (objvar)
 296                (let1 (comp prop e)
 297                      (lambda (propvar)
 298                        (begin1 (-> (call (-> (primitive '-))
 299                                          (@impl pget
 300                                                 (-> (lexical objvar objvar))
 301                                                 (-> (lexical propvar propvar)))
 302                                          (-> (const 1))))
 303                                (lambda (tmpvar)
 304                                  (@impl pput
 305                                         (-> (lexical objvar objvar))
 306                                         (-> (lexical propvar propvar))
 307                                         (-> (lexical tmpvar tmpvar))))))))))
 308       ((ref ,id)
 309        (lookup id e))
 310       ((var . ,forms)
 311        `(begin
 312           ,@(map (lambda (form)
 313                    (pmatch form
 314                      ((,x ,y)
 315                       (-> (define x (comp y e))))
 316                      ((,x)
 317                       (-> (define x (@implv *undefined*))))
 318                      (else (error "bad var form" form))))
 319                  forms)))
 320       ((begin)
 321        (-> (void)))
 322       ((begin ,form)
 323        (comp form e))
 324       ((begin . ,forms)
 325        `(begin ,@(map (lambda (x) (comp x e)) forms)))
 326       ((lambda ,formals ,body)
 327        (let ((syms (map (lambda (x)
 328                           (gensym (string-append (symbol->string x) " ")))
 329                         formals)))
 330          `(lambda ()
 331             (lambda-case
 332              ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms)
 333               ,(comp-body e body formals syms))))))
 334       ((call/this ,obj ,prop . ,args)
 335        (@impl call/this*
 336               obj
 337               (-> (lambda '()
 338                     `(lambda-case
 339                       ((() #f #f #f () ())
 340                        (call ,(@impl pget obj prop) ,@args)))))))
 341       ((call (pref ,obj ,prop) ,args)
 342        (comp `(call/this ,(comp obj e)
 343                          ,(-> (const prop))
 344                          ,@(map (lambda (x) (comp x e)) args))
 345              e))
 346       ((call (aref ,obj ,prop) ,args)
 347        (comp `(call/this ,(comp obj e)
 348                          ,(comp prop e)
 349                          ,@(map (lambda (x) (comp x e)) args))
 350              e))
 351       ((call ,proc ,args)
 352        `(call ,(comp proc e)
 353               ,@(map (lambda (x) (comp x e)) args)))
 354       ((return ,expr)
 355        (-> (call (-> (primitive 'return))
 356                  (comp expr e))))
 357       ((array . ,args)
 358        `(call ,(@implv new-array)
 359               ,@(map (lambda (x) (comp x e)) args)))
 360       ((object . ,args)
 361        `(call ,(@implv new-object)
 362               ,@(map (lambda (x)
 363                        (pmatch x
 364                          ((,prop ,val)
 365                           (-> (call (-> (primitive 'cons))
 366                                     (-> (const prop))
 367                                     (comp val e))))
 368                          (else
 369                           (error "bad prop-val pair" x))))
 370                      args)))
 371       ((pref ,obj ,prop)
 372        (@impl pget
 373               (comp obj e)
 374               (-> (const prop))))
 375       ((aref ,obj ,index)
 376        (@impl pget
 377               (comp obj e)
 378               (comp index e)))
 379       ((= (ref ,name) ,val)
 380        (let ((v (lookup name e)))
 381          (-> (begin
 382                (-> (set! v (comp val e)))
 383                v))))
 384       ((= (pref ,obj ,prop) ,val)
 385        (@impl pput
 386               (comp obj e)
 387               (-> (const prop))
 388               (comp val e)))
 389       ((= (aref ,obj ,prop) ,val)
 390        (@impl pput
 391               (comp obj e)
 392               (comp prop e)
 393               (comp val e)))
 394       ((+= ,what ,val)
 395        (comp `(= ,what (+ ,what ,val)) e))
 396       ((-= ,what ,val)
 397        (comp `(= ,what (- ,what ,val)) e))
 398       ((/= ,what ,val)
 399        (comp `(= ,what (/ ,what ,val)) e))
 400       ((*= ,what ,val)
 401        (comp `(= ,what (* ,what ,val)) e))
 402       ((%= ,what ,val)
 403        (comp `(= ,what (% ,what ,val)) e))
 404       ((>>= ,what ,val)
 405        (comp `(= ,what (>> ,what ,val)) e))
 406       ((<<= ,what ,val)
 407        (comp `(= ,what (<< ,what ,val)) e))
 408       ((>>>= ,what ,val)
 409        (comp `(= ,what (>>> ,what ,val)) e))
 410       ((&= ,what ,val)
 411        (comp `(= ,what (& ,what ,val)) e))
 412       ((bor= ,what ,val)
 413        (comp `(= ,what (bor ,what ,val)) e))
 414       ((^= ,what ,val)
 415        (comp `(= ,what (^ ,what ,val)) e))
 416       ((new ,what ,args)
 417        (@impl new
 418               (map (lambda (x) (comp x e))
 419                    (cons what args))))
 420       ((delete (pref ,obj ,prop))
 421        (@impl pdel
 422               (comp obj e)
 423               (-> (const prop))))
 424       ((delete (aref ,obj ,prop))
 425        (@impl pdel
 426               (comp obj e)
 427               (comp prop e)))
 428       ((void ,expr)
 429        (-> (begin
 430              (comp expr e)
 431              (@implv *undefined*))))
 432       ((typeof ,expr)
 433        (@impl typeof
 434               (comp expr e)))
 435       ((do ,statement ,test)
 436        (let ((%loop (gensym "%loop "))
 437              (%continue (gensym "%continue ")))
 438          (let ((e (econs '%loop %loop (econs '%continue %continue e))))
 439            (-> (letrec '(%loop %continue) (list %loop %continue)
 440                        (list (-> (lambda '()
 441                                    (-> (lambda-case
 442                                         `((() #f #f #f () ())
 443                                           ,(-> (begin
 444                                                  (comp statement e)
 445                                                  (-> (call (-> (lexical '%continue %continue)))))))))))
 446                              (-> (lambda '()
 447                                    (-> (lambda-case
 448                                         `((() #f #f #f () ())
 449                                           ,(-> (if (@impl ->boolean (comp test e))
 450                                                    (-> (call (-> (lexical '%loop %loop))))
 451                                                    (@implv *undefined*)))))))))
 452                        (-> (call (-> (lexical '%loop %loop)))))))))
 453       ((while ,test ,statement)
 454        (let ((%continue (gensym "%continue ")))
 455          (let ((e (econs '%continue %continue e)))
 456            (-> (letrec '(%continue) (list %continue)
 457                        (list (-> (lambda '()
 458                                    (-> (lambda-case
 459                                         `((() #f #f #f () ())
 460                                           ,(-> (if (@impl ->boolean (comp test e))
 461                                                    (-> (begin (comp statement e)
 462                                                               (-> (call (-> (lexical '%continue %continue))))))
 463                                                    (@implv *undefined*)))))))))
 464                        (-> (call (-> (lexical '%continue %continue)))))))))
 465
 466       ((for ,init ,test ,inc ,statement)
 467        (let ((%continue (gensym "%continue ")))
 468          (let ((e (econs '%continue %continue e)))
 469            (-> (letrec '(%continue) (list %continue)
 470                        (list (-> (lambda '()
 471                                    (-> (lambda-case
 472                                         `((() #f #f #f () ())
 473                                           ,(-> (if (if test
 474                                                        (@impl ->boolean (comp test e))
 475                                                        (comp 'true e))
 476                                                    (-> (begin (comp statement e)
 477                                                               (comp (or inc '(begin)) e)
 478                                                               (-> (call (-> (lexical '%continue %continue))))))
 479                                                    (@implv *undefined*)))))))))
 480                        (-> (begin (comp (or init '(begin)) e)
 481                                   (-> (call (-> (lexical '%continue %continue)))))))))))
 482
 483       ((for-in ,var ,object ,statement)
 484        (let ((%enum (gensym "%enum "))
 485              (%continue (gensym "%continue ")))
 486          (let ((e (econs '%enum %enum (econs '%continue %continue e))))
 487            (-> (letrec '(%enum %continue) (list %enum %continue)
 488                        (list (@impl make-enumerator (comp object e))
 489                              (-> (lambda '()
 490                                    (-> (lambda-case
 491                                         `((() #f #f #f () ())
 492                                           (-> (if (@impl ->boolean
 493                                                          (@impl pget
 494                                                                 (-> (lexical '%enum %enum))
 495                                                                 (-> (const 'length))))
 496                                                   (-> (begin
 497                                                         (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
 498                                                                                   ,(-> (const 'pop))))
 499                                                               e)
 500                                                         (comp statement e)
 501                                                         (-> (call (-> (lexical '%continue %continue))))))
 502                                                   (@implv *undefined*)))))))))
 503                        (-> (call (-> (lexical '%continue %continue)))))))))
 504
 505       ((block ,x)
 506        (comp x e))
 507       (else
 508        (error "compilation not yet implemented:" x)))))
 509
 510 (define (comp-body e body formals formal-syms)
 511   (define (process)
 512     (let lp ((in body) (out '()) (rvars '()))
 513       (pmatch in
 514         (((var (,x) . ,morevars) . ,rest)
 515          (lp `((var . ,morevars) . ,rest)
 516              out
 517              (if (or (memq x rvars) (memq x formals))
 518                  rvars
 519                  (cons x rvars))))
 520         (((var (,x ,y) . ,morevars) . ,rest)
 521          (lp `((var . ,morevars) . ,rest)
 522              `((= (ref ,x) ,y) . ,out)
 523              (if (or (memq x rvars) (memq x formals))
 524                  rvars
 525                  (cons x rvars))))
 526         (((var) . ,rest)
 527          (lp rest out rvars))
 528         ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
 529          (lp rest
 530              (cons x out)
 531              rvars))
 532         ((,x . ,rest) (guard (pair? x))
 533          (receive (sub-out rvars)
 534              (lp x '() rvars)
 535            (lp rest
 536                (cons sub-out out)
 537                rvars)))
 538         ((,x . ,rest)
 539          (lp rest
 540              (cons x out)
 541              rvars))
 542         (()
 543          (values (reverse! out)
 544                  rvars)))))
 545   (receive (out rvars)
 546       (process)
 547     (let* ((names (reverse rvars))
 548            (syms (map (lambda (x)
 549                         (gensym (string-append (symbol->string x) " ")))
 550                       names))
 551            (e (fold econs (fold econs e formals formal-syms) names syms)))
 552       (-> (let names syms (map (lambda (x) (@implv *undefined*)) names)
 553                (comp out e))))))