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

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