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 current-return-tag (make-parameter #f))
  74
  75 (define (return expr)
  76   (-> (abort (or (current-return-tag) (error "return outside function"))
  77              (list expr)
  78              (-> (const '())))))
  79
  80 (define (with-return-prompt body-thunk)
  81   (let ((tag (gensym "return")))
  82     (parameterize ((current-return-tag
  83                     (-> (lexical 'return tag))))
  84       (-> (let '(return) (list tag)
  85                (list (-> (primcall 'make-prompt-tag)))
  86                (-> (prompt #t
  87                            (current-return-tag)
  88                            (body-thunk)
  89                            (let ((val (gensym "val")))
  90                              (-> (lambda '()
  91                                    (-> (lambda-case
  92                                         `(((k val) #f #f #f () (,(gensym) ,val))
  93                                           ,(-> (lexical 'val val)))))))))))))))
  94
  95 (define (comp x e)
  96   (let ((l (location x)))
  97     (define (let1 what proc)
  98       (let ((sym (gensym)))
  99         (-> (let (list sym) (list sym) (list what)
 100                  (proc sym)))))
 101     (define (begin1 what proc)
 102       (let1 what (lambda (v)
 103                    (-> (begin (proc v)
 104                               (-> (lexical v v)))))))
 105     (pmatch/source x
 106       (null
 107        ;; FIXME, null doesn't have much relation to EOL...
 108        (-> (const '())))
 109       (true
 110        (-> (const #t)))
 111       (false
 112        (-> (const #f)))
 113       ((number ,num)
 114        (-> (const num)))
 115       ((string ,str)
 116        (-> (const str)))
 117       (this
 118        (@impl get-this))
 119       ((+ ,a)
 120        (-> (call (-> (primitive '+))
 121                  (@impl ->number (comp a e))
 122                  (-> (const 0)))))
 123       ((- ,a)
 124        (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
 125       ((~ ,a)
 126        (@impl bitwise-not (comp a e)))
 127       ((! ,a)
 128        (@impl logical-not (comp a e)))
 129       ((+ ,a ,b)
 130        (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
 131       ((- ,a ,b)
 132        (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
 133       ((/ ,a ,b)
 134        (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
 135       ((* ,a ,b)
 136        (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
 137       ((% ,a ,b)
 138        (@impl mod (comp a e) (comp b e)))
 139       ((<< ,a ,b)
 140        (@impl shift (comp a e) (comp b e)))
 141       ((>> ,a ,b)
 142        (@impl shift (comp a e) (comp `(- ,b) e)))
 143       ((< ,a ,b)
 144        (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
 145       ((<= ,a ,b)
 146        (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
 147       ((> ,a ,b)
 148        (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
 149       ((>= ,a ,b)
 150        (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
 151       ((in ,a ,b)
 152        (@impl has-property? (comp a e) (comp b e)))
 153       ((== ,a ,b)
 154        (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
 155       ((!= ,a ,b)
 156        (-> (call (-> (primitive 'not))
 157                  (-> (call (-> (primitive 'equal?))
 158                            (comp a e) (comp b e))))))
 159       ((=== ,a ,b)
 160        (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
 161       ((!== ,a ,b)
 162        (-> (call (-> (primitive 'not))
 163                  (-> (call (-> (primitive 'eqv?))
 164                            (comp a e) (comp b e))))))
 165       ((& ,a ,b)
 166        (@impl band (comp a e) (comp b e)))
 167       ((^ ,a ,b)
 168        (@impl bxor (comp a e) (comp b e)))
 169       ((bor ,a ,b)
 170        (@impl bior (comp a e) (comp b e)))
 171       ((and ,a ,b)
 172        (-> (if (@impl ->boolean (comp a e))
 173                (comp b e)
 174                (-> (const #f)))))
 175       ((or ,a ,b)
 176        (let1 (comp a e)
 177              (lambda (v)
 178                (-> (if (@impl ->boolean (-> (lexical v v)))
 179                        (-> (lexical v v))
 180                        (comp b e))))))
 181       ((if ,test ,then ,else)
 182        (-> (if (@impl ->boolean (comp test e))
 183                (comp then e)
 184                (comp else e))))
 185       ((if ,test ,then)
 186        (-> (if (@impl ->boolean (comp test e))
 187                (comp then e)
 188                (@implv *undefined*))))
 189       ((postinc (ref ,foo))
 190        (begin1 (comp `(ref ,foo) e)
 191                (lambda (var)
 192                  (-> (set! (lookup foo e)
 193                            (-> (call (-> (primitive '+))
 194                                      (-> (lexical var var))
 195                                      (-> (const 1)))))))))
 196       ((postinc (pref ,obj ,prop))
 197        (let1 (comp obj e)
 198              (lambda (objvar)
 199                (begin1 (@impl pget
 200                               (-> (lexical objvar objvar))
 201                               (-> (const prop)))
 202                        (lambda (tmpvar)
 203                          (@impl pput
 204                                 (-> (lexical objvar objvar))
 205                                 (-> (const prop))
 206                                 (-> (call (-> (primitive '+))
 207                                           (-> (lexical tmpvar tmpvar))
 208                                           (-> (const 1))))))))))
 209       ((postinc (aref ,obj ,prop))
 210        (let1 (comp obj e)
 211              (lambda (objvar)
 212                (let1 (comp prop e)
 213                      (lambda (propvar)
 214                        (begin1 (@impl pget
 215                                       (-> (lexical objvar objvar))
 216                                       (-> (lexical propvar propvar)))
 217                                (lambda (tmpvar)
 218                                  (@impl pput
 219                                         (-> (lexical objvar objvar))
 220                                         (-> (lexical propvar propvar))
 221                                         (-> (call (-> (primitive '+))
 222                                                   (-> (lexical tmpvar tmpvar))
 223                                                   (-> (const 1))))))))))))
 224       ((postdec (ref ,foo))
 225        (begin1 (comp `(ref ,foo) e)
 226                (lambda (var)
 227                  (-> (set (lookup foo e)
 228                           (-> (call (-> (primitive '-))
 229                                     (-> (lexical var var))
 230                                     (-> (const 1)))))))))
 231       ((postdec (pref ,obj ,prop))
 232        (let1 (comp obj e)
 233              (lambda (objvar)
 234                (begin1 (@impl pget
 235                               (-> (lexical objvar objvar))
 236                               (-> (const prop)))
 237                        (lambda (tmpvar)
 238                          (@impl pput
 239                                 (-> (lexical objvar objvar))
 240                                 (-> (const prop))
 241                                 (-> (call (-> (primitive '-))
 242                                           (-> (lexical tmpvar tmpvar))
 243                                           (-> (const 1))))))))))
 244       ((postdec (aref ,obj ,prop))
 245        (let1 (comp obj e)
 246              (lambda (objvar)
 247                (let1 (comp prop e)
 248                      (lambda (propvar)
 249                        (begin1 (@impl pget
 250                                       (-> (lexical objvar objvar))
 251                                       (-> (lexical propvar propvar)))
 252                                (lambda (tmpvar)
 253                                  (@impl pput
 254                                         (-> (lexical objvar objvar))
 255                                         (-> (lexical propvar propvar))
 256                                         (-> (inline
 257                                              '- (-> (lexical tmpvar tmpvar))
 258                                              (-> (const 1))))))))))))
 259       ((preinc (ref ,foo))
 260        (let ((v (lookup foo e)))
 261          (-> (begin
 262                (-> (set! v
 263                          (-> (call (-> (primitive '+))
 264                                    v
 265                                    (-> (const 1))))))
 266                v))))
 267       ((preinc (pref ,obj ,prop))
 268        (let1 (comp obj e)
 269              (lambda (objvar)
 270                (begin1 (-> (call (-> (primitive '+))
 271                                  (@impl pget
 272                                         (-> (lexical objvar objvar))
 273                                         (-> (const prop)))
 274                                  (-> (const 1))))
 275                        (lambda (tmpvar)
 276                          (@impl pput (-> (lexical objvar objvar))
 277                                 (-> (const prop))
 278                                 (-> (lexical tmpvar tmpvar))))))))
 279       ((preinc (aref ,obj ,prop))
 280        (let1 (comp obj e)
 281              (lambda (objvar)
 282                (let1 (comp prop e)
 283                      (lambda (propvar)
 284                        (begin1 (-> (call (-> (primitive '+))
 285                                          (@impl pget
 286                                                 (-> (lexical objvar objvar))
 287                                                 (-> (lexical propvar propvar)))
 288                                          (-> (const 1))))
 289                                (lambda (tmpvar)
 290                                  (@impl pput
 291                                         (-> (lexical objvar objvar))
 292                                         (-> (lexical propvar propvar))
 293                                         (-> (lexical tmpvar tmpvar))))))))))
 294       ((predec (ref ,foo))
 295        (let ((v (lookup foo e)))
 296          (-> (begin
 297                (-> (set! v
 298                          (-> (call (-> (primitive '-))
 299                                    v
 300                                    (-> (const 1))))))
 301                v))))
 302       ((predec (pref ,obj ,prop))
 303        (let1 (comp obj e)
 304              (lambda (objvar)
 305                (begin1 (-> (call (-> (primitive '-))
 306                                  (@impl pget
 307                                         (-> (lexical objvar objvar))
 308                                         (-> (const prop)))
 309                                  (-> (const 1))))
 310                        (lambda (tmpvar)
 311                          (@impl pput
 312                                 (-> (lexical objvar objvar))
 313                                 (-> (const prop))
 314                                 (-> (lexical tmpvar tmpvar))))))))
 315       ((predec (aref ,obj ,prop))
 316        (let1 (comp obj e)
 317              (lambda (objvar)
 318                (let1 (comp prop e)
 319                      (lambda (propvar)
 320                        (begin1 (-> (call (-> (primitive '-))
 321                                          (@impl pget
 322                                                 (-> (lexical objvar objvar))
 323                                                 (-> (lexical propvar propvar)))
 324                                          (-> (const 1))))
 325                                (lambda (tmpvar)
 326                                  (@impl pput
 327                                         (-> (lexical objvar objvar))
 328                                         (-> (lexical propvar propvar))
 329                                         (-> (lexical tmpvar tmpvar))))))))))
 330       ((ref ,id)
 331        (lookup id e))
 332       ((var . ,forms)
 333        `(begin
 334           ,@(map (lambda (form)
 335                    (pmatch form
 336                      ((,x ,y)
 337                       (-> (define x (comp y e))))
 338                      ((,x)
 339                       (-> (define x (@implv *undefined*))))
 340                      (else (error "bad var form" form))))
 341                  forms)))
 342       ((begin)
 343        (-> (void)))
 344       ((begin ,form)
 345        (comp form e))
 346       ((begin . ,forms)
 347        `(begin ,@(map (lambda (x) (comp x e)) forms)))
 348       ((lambda ,formals ,body)
 349        (let ((syms (map (lambda (x)
 350                           (gensym (string-append (symbol->string x) " ")))
 351                         formals)))
 352          `(lambda ()
 353             (lambda-case
 354              ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms)
 355               ,(with-return-prompt
 356                 (lambda ()
 357                   (comp-body e body formals syms))))))))
 358       ((call/this ,obj ,prop . ,args)
 359        (@impl call/this*
 360               obj
 361               (-> (lambda '()
 362                     `(lambda-case
 363                       ((() #f #f #f () ())
 364                        (call ,(@impl pget obj prop) ,@args)))))))
 365       ((call (pref ,obj ,prop) ,args)
 366        (comp `(call/this ,(comp obj e)
 367                          ,(-> (const prop))
 368                          ,@(map (lambda (x) (comp x e)) args))
 369              e))
 370       ((call (aref ,obj ,prop) ,args)
 371        (comp `(call/this ,(comp obj e)
 372                          ,(comp prop e)
 373                          ,@(map (lambda (x) (comp x e)) args))
 374              e))
 375       ((call ,proc ,args)
 376        `(call ,(comp proc e)
 377               ,@(map (lambda (x) (comp x e)) args)))
 378       ((return ,expr)
 379        (return (comp expr e)))
 380       ((array . ,args)
 381        `(call ,(@implv new-array)
 382               ,@(map (lambda (x) (comp x e)) args)))
 383       ((object . ,args)
 384        `(call ,(@implv new-object)
 385               ,@(map (lambda (x)
 386                        (pmatch x
 387                          ((,prop ,val)
 388                           (-> (call (-> (primitive 'cons))
 389                                     (-> (const prop))
 390                                     (comp val e))))
 391                          (else
 392                           (error "bad prop-val pair" x))))
 393                      args)))
 394       ((pref ,obj ,prop)
 395        (@impl pget
 396               (comp obj e)
 397               (-> (const prop))))
 398       ((aref ,obj ,index)
 399        (@impl pget
 400               (comp obj e)
 401               (comp index e)))
 402       ((= (ref ,name) ,val)
 403        (let ((v (lookup name e)))
 404          (-> (begin
 405                (-> (set! v (comp val e)))
 406                v))))
 407       ((= (pref ,obj ,prop) ,val)
 408        (@impl pput
 409               (comp obj e)
 410               (-> (const prop))
 411               (comp val e)))
 412       ((= (aref ,obj ,prop) ,val)
 413        (@impl pput
 414               (comp obj e)
 415               (comp prop e)
 416               (comp val e)))
 417       ((+= ,what ,val)
 418        (comp `(= ,what (+ ,what ,val)) e))
 419       ((-= ,what ,val)
 420        (comp `(= ,what (- ,what ,val)) e))
 421       ((/= ,what ,val)
 422        (comp `(= ,what (/ ,what ,val)) e))
 423       ((*= ,what ,val)
 424        (comp `(= ,what (* ,what ,val)) e))
 425       ((%= ,what ,val)
 426        (comp `(= ,what (% ,what ,val)) e))
 427       ((>>= ,what ,val)
 428        (comp `(= ,what (>> ,what ,val)) e))
 429       ((<<= ,what ,val)
 430        (comp `(= ,what (<< ,what ,val)) e))
 431       ((>>>= ,what ,val)
 432        (comp `(= ,what (>>> ,what ,val)) e))
 433       ((&= ,what ,val)
 434        (comp `(= ,what (& ,what ,val)) e))
 435       ((bor= ,what ,val)
 436        (comp `(= ,what (bor ,what ,val)) e))
 437       ((^= ,what ,val)
 438        (comp `(= ,what (^ ,what ,val)) e))
 439       ((new ,what ,args)
 440        (@impl new
 441               (map (lambda (x) (comp x e))
 442                    (cons what args))))
 443       ((delete (pref ,obj ,prop))
 444        (@impl pdel
 445               (comp obj e)
 446               (-> (const prop))))
 447       ((delete (aref ,obj ,prop))
 448        (@impl pdel
 449               (comp obj e)
 450               (comp prop e)))
 451       ((void ,expr)
 452        (-> (begin
 453              (comp expr e)
 454              (@implv *undefined*))))
 455       ((typeof ,expr)
 456        (@impl typeof
 457               (comp expr e)))
 458       ((do ,statement ,test)
 459        (let ((%loop (gensym "%loop "))
 460              (%continue (gensym "%continue ")))
 461          (let ((e (econs '%loop %loop (econs '%continue %continue e))))
 462            (-> (letrec '(%loop %continue) (list %loop %continue)
 463                        (list (-> (lambda '()
 464                                    (-> (lambda-case
 465                                         `((() #f #f #f () ())
 466                                           ,(-> (begin
 467                                                  (comp statement e)
 468                                                  (-> (call (-> (lexical '%continue %continue)))))))))))
 469                              (-> (lambda '()
 470                                    (-> (lambda-case
 471                                         `((() #f #f #f () ())
 472                                           ,(-> (if (@impl ->boolean (comp test e))
 473                                                    (-> (call (-> (lexical '%loop %loop))))
 474                                                    (@implv *undefined*)))))))))
 475                        (-> (call (-> (lexical '%loop %loop)))))))))
 476       ((while ,test ,statement)
 477        (let ((%continue (gensym "%continue ")))
 478          (let ((e (econs '%continue %continue e)))
 479            (-> (letrec '(%continue) (list %continue)
 480                        (list (-> (lambda '()
 481                                    (-> (lambda-case
 482                                         `((() #f #f #f () ())
 483                                           ,(-> (if (@impl ->boolean (comp test e))
 484                                                    (-> (begin (comp statement e)
 485                                                               (-> (call (-> (lexical '%continue %continue))))))
 486                                                    (@implv *undefined*)))))))))
 487                        (-> (call (-> (lexical '%continue %continue)))))))))
 488
 489       ((for ,init ,test ,inc ,statement)
 490        (let ((%continue (gensym "%continue ")))
 491          (let ((e (econs '%continue %continue e)))
 492            (-> (letrec '(%continue) (list %continue)
 493                        (list (-> (lambda '()
 494                                    (-> (lambda-case
 495                                         `((() #f #f #f () ())
 496                                           ,(-> (if (if test
 497                                                        (@impl ->boolean (comp test e))
 498                                                        (comp 'true e))
 499                                                    (-> (begin (comp statement e)
 500                                                               (comp (or inc '(begin)) e)
 501                                                               (-> (call (-> (lexical '%continue %continue))))))
 502                                                    (@implv *undefined*)))))))))
 503                        (-> (begin (comp (or init '(begin)) e)
 504                                   (-> (call (-> (lexical '%continue %continue)))))))))))
 505
 506       ((for-in ,var ,object ,statement)
 507        (let ((%enum (gensym "%enum "))
 508              (%continue (gensym "%continue ")))
 509          (let ((e (econs '%enum %enum (econs '%continue %continue e))))
 510            (-> (letrec '(%enum %continue) (list %enum %continue)
 511                        (list (@impl make-enumerator (comp object e))
 512                              (-> (lambda '()
 513                                    (-> (lambda-case
 514                                         `((() #f #f #f () ())
 515                                           (-> (if (@impl ->boolean
 516                                                          (@impl pget
 517                                                                 (-> (lexical '%enum %enum))
 518                                                                 (-> (const 'length))))
 519                                                   (-> (begin
 520                                                         (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
 521                                                                                   ,(-> (const 'pop))))
 522                                                               e)
 523                                                         (comp statement e)
 524                                                         (-> (call (-> (lexical '%continue %continue))))))
 525                                                   (@implv *undefined*)))))))))
 526                        (-> (call (-> (lexical '%continue %continue)))))))))
 527
 528       ((block ,x)
 529        (comp x e))
 530       (else
 531        (error "compilation not yet implemented:" x)))))
 532
 533 (define (comp-body e body formals formal-syms)
 534   (define (process)
 535     (let lp ((in body) (out '()) (rvars '()))
 536       (pmatch in
 537         (((var (,x) . ,morevars) . ,rest)
 538          (lp `((var . ,morevars) . ,rest)
 539              out
 540              (if (or (memq x rvars) (memq x formals))
 541                  rvars
 542                  (cons x rvars))))
 543         (((var (,x ,y) . ,morevars) . ,rest)
 544          (lp `((var . ,morevars) . ,rest)
 545              `((= (ref ,x) ,y) . ,out)
 546              (if (or (memq x rvars) (memq x formals))
 547                  rvars
 548                  (cons x rvars))))
 549         (((var) . ,rest)
 550          (lp rest out rvars))
 551         ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
 552          (lp rest
 553              (cons x out)
 554              rvars))
 555         ((,x . ,rest) (guard (pair? x))
 556          (receive (sub-out rvars)
 557              (lp x '() rvars)
 558            (lp rest
 559                (cons sub-out out)
 560                rvars)))
 561         ((,x . ,rest)
 562          (lp rest
 563              (cons x out)
 564              rvars))
 565         (()
 566          (values (reverse! out)
 567                  rvars)))))
 568   (receive (out rvars)
 569       (process)
 570     (let* ((names (reverse rvars))
 571            (syms (map (lambda (x)
 572                         (gensym (string-append (symbol->string x) " ")))
 573                       names))
 574            (e (fold econs (fold econs e formals formal-syms) names syms)))
 575       (-> (let names syms (map (lambda (x) (@implv *undefined*)) names)
 576                (comp out e))))))