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