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