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 ((%args (gensym "%args ")))
 330          (-> (lambda '%args %args '()
 331                      (comp-body (econs '%args %args e) body formals '%args)))))
 332       ((call/this ,obj ,prop . ,args)
 333        (@impl call/this*
 334               obj
 335               (-> (lambda '() '() '()
 336                           `(apply ,(@impl pget obj prop) ,@args)))))
 337       ((call (pref ,obj ,prop) ,args)
 338        (comp `(call/this ,(comp obj e)
 339                          ,(-> (const prop))
 340                          ,@(map (lambda (x) (comp x e)) args))
 341              e))
 342       ((call (aref ,obj ,prop) ,args)
 343        (comp `(call/this ,(comp obj e)
 344                          ,(comp prop e)
 345                          ,@(map (lambda (x) (comp x e)) args))
 346              e))
 347       ((call ,proc ,args)
 348        `(apply ,(comp proc e)
 349                ,@(map (lambda (x) (comp x e)) args)))
 350       ((return ,expr)
 351        (-> (apply (-> (primitive 'return))
 352                   (comp expr e))))
 353       ((array . ,args)
 354        `(apply ,(@implv new-array)
 355                ,@(map (lambda (x) (comp x e)) args)))
 356       ((object . ,args)
 357        (@impl new-object
 358               (map (lambda (x)
 359                      (pmatch x
 360                        ((,prop ,val)
 361                         (-> (apply (-> (primitive 'cons))
 362                                    (-> (const prop))
 363                                    (comp val e))))
 364                        (else
 365                         (error "bad prop-val pair" x))))
 366                    args)))
 367       ((pref ,obj ,prop)
 368        (@impl pget
 369               (comp obj e)
 370               (-> (const prop))))
 371       ((aref ,obj ,index)
 372        (@impl pget
 373               (comp obj e)
 374               (comp index e)))
 375       ((= (ref ,name) ,val)
 376        (let ((v (lookup name e)))
 377          (-> (begin
 378                (-> (set! v (comp val e)))
 379                v))))
 380       ((= (pref ,obj ,prop) ,val)
 381        (@impl pput
 382               (comp obj e)
 383               (-> (const prop))
 384               (comp val e)))
 385       ((= (aref ,obj ,prop) ,val)
 386        (@impl pput
 387               (comp obj e)
 388               (comp prop e)
 389               (comp val e)))
 390       ((+= ,what ,val)
 391        (comp `(= ,what (+ ,what ,val)) e))
 392       ((-= ,what ,val)
 393        (comp `(= ,what (- ,what ,val)) e))
 394       ((/= ,what ,val)
 395        (comp `(= ,what (/ ,what ,val)) e))
 396       ((*= ,what ,val)
 397        (comp `(= ,what (* ,what ,val)) e))
 398       ((%= ,what ,val)
 399        (comp `(= ,what (% ,what ,val)) e))
 400       ((>>= ,what ,val)
 401        (comp `(= ,what (>> ,what ,val)) e))
 402       ((<<= ,what ,val)
 403        (comp `(= ,what (<< ,what ,val)) e))
 404       ((>>>= ,what ,val)
 405        (comp `(= ,what (>>> ,what ,val)) e))
 406       ((&= ,what ,val)
 407        (comp `(= ,what (& ,what ,val)) e))
 408       ((bor= ,what ,val)
 409        (comp `(= ,what (bor ,what ,val)) e))
 410       ((^= ,what ,val)
 411        (comp `(= ,what (^ ,what ,val)) e))
 412       ((new ,what ,args)
 413        (@impl new
 414               (map (lambda (x) (comp x e))
 415                    (cons what args))))
 416       ((delete (pref ,obj ,prop))
 417        (@impl pdel
 418               (comp obj e)
 419               (-> (const prop))))
 420       ((delete (aref ,obj ,prop))
 421        (@impl pdel
 422               (comp obj e)
 423               (comp prop e)))
 424       ((void ,expr)
 425        (-> (begin
 426              (comp expr e)
 427              (@implv *undefined*))))
 428       ((typeof ,expr)
 429        (@impl typeof
 430               (comp expr e)))
 431       ((do ,statement ,test)
 432        (let ((%loop (gensym "%loop "))
 433              (%continue (gensym "%continue ")))
 434          (let ((e (econs '%loop %loop (econs '%continue %continue e))))
 435            (-> (letrec '(%loop %continue) (list %loop %continue)
 436                        (list (-> (lambda '() '() '()
 437                                          (-> (begin
 438                                                (comp statement e)
 439                                                (-> (apply (-> (lexical '%continue %continue)))
 440                                                    )))))
 441
 442                              (-> (lambda '() '() '()
 443                                          (-> (if (@impl ->boolean (comp test e))
 444                                                  (-> (apply (-> (lexical '%loop %loop))))
 445                                                  (@implv *undefined*))))))
 446                        (-> (apply (-> (lexical '%loop %loop)))))))))
 447       ((while ,test ,statement)
 448        (let ((%continue (gensym "%continue ")))
 449          (let ((e (econs '%continue %continue e)))
 450            (-> (letrec '(%continue) (list %continue)
 451                        (list (-> (lambda '() '() '()
 452                                          (-> (if (@impl ->boolean (comp test e))
 453                                                  (-> (begin (comp statement e)
 454                                                             (-> (apply (-> (lexical '%continue %continue))))))
 455                                                  (@implv *undefined*))))))
 456                        (-> (apply (-> (lexical '%continue %continue)))))))))
 457
 458       ((for ,init ,test ,inc ,statement)
 459        (let ((%continue (gensym "%continue ")))
 460          (let ((e (econs '%continue %continue e)))
 461            (-> (letrec '(%continue) (list %continue)
 462                        (list (-> (lambda '() '() '()
 463                                          (-> (if (if test
 464                                                      (@impl ->boolean (comp test e))
 465                                                      (comp 'true e))
 466                                                  (-> (begin (comp statement e)
 467                                                             (comp (or inc '(begin)) e)
 468                                                             (-> (apply (-> (lexical '%continue %continue))))))
 469                                                  (@implv *undefined*))))))
 470                        (-> (begin (comp (or init '(begin)) e)
 471                                   (-> (apply (-> (lexical '%continue %continue)))))))))))
 472
 473       ((for-in ,var ,object ,statement)
 474        (let ((%enum (gensym "%enum "))
 475              (%continue (gensym "%continue ")))
 476          (let ((e (econs '%enum %enum (econs '%continue %continue e))))
 477            (-> (letrec '(%enum %continue) (list %enum %continue)
 478                        (list (@impl make-enumerator (comp object e))
 479                              (-> (lambda '() '() '()
 480                                          (-> (if (@impl ->boolean
 481                                                         (@impl pget
 482                                                                (-> (lexical '%enum %enum))
 483                                                                (-> (const 'length))))
 484                                                  (-> (begin
 485                                                        (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
 486                                                                                  ,(-> (const 'pop))))
 487                                                              e)
 488                                                        (comp statement e)
 489                                                        (-> (apply (-> (lexical '%continue %continue))))))
 490                                                  (@implv *undefined*))))))
 491                        (-> (apply (-> (lexical '%continue %continue)))))))))
 492
 493       ((block ,x)
 494        (comp x e))
 495       (else
 496        (error "compilation not yet implemented:" x)))))
 497
 498 (define (comp-body e body formals %args)
 499   (define (process)
 500     (let lp ((in body) (out '()) (rvars (reverse formals)))
 501       (pmatch in
 502         (((var (,x) . ,morevars) . ,rest)
 503          (lp `((var . ,morevars) . ,rest)
 504              out
 505              (if (memq x rvars) rvars (cons x rvars))))
 506         (((var (,x ,y) . ,morevars) . ,rest)
 507          (lp `((var . ,morevars) . ,rest)
 508              `((= (ref ,x) ,y) . ,out)
 509              (if (memq x rvars) rvars (cons x rvars))))
 510         (((var) . ,rest)
 511          (lp rest out rvars))
 512         ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
 513          (lp rest
 514              (cons x out)
 515              rvars))
 516         ((,x . ,rest) (guard (pair? x))
 517          (receive (sub-out rvars)
 518              (lp x '() rvars)
 519            (lp rest
 520                (cons sub-out out)
 521                rvars)))
 522         ((,x . ,rest)
 523          (lp rest
 524              (cons x out)
 525              rvars))
 526         (()
 527          (values (reverse! out)
 528                  rvars)))))
 529   (receive (out rvars)
 530       (process)
 531     (let* ((names (reverse rvars))
 532            (syms (map (lambda (x)
 533                         (gensym (string-append (symbol->string x) " ")))
 534                       names))
 535            (e (fold acons e names syms)))
 536       (let ((%argv (lookup %args e)))
 537         (let lp ((names names) (syms syms))
 538           (if (null? names)
 539               ;; fixme: here check for too many args
 540               (comp out e)
 541               (-> (let (list (car names)) (list (car syms))
 542                        (list (-> (if (-> (apply (-> (primitive 'null?)) %argv))
 543                                      (-> (@implv *undefined*))
 544                                      (-> (let1 (-> (apply (-> (primitive 'car)) %argv))
 545                                                (lambda (v)
 546                                                  (-> (set! %argv
 547                                                      (-> (apply (-> (primitive 'cdr)) %argv))))
 548                                                  (-> (lexical v v))))))))
 549                        (lp (cdr names) (cdr syms))))))))))