module/language/ecmascript/compile-ghil.scm

   1 ;;; ECMAScript for Guile
   2
   3 ;; Copyright (C) 2009 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9 ;;
  10 ;; This program 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
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 (define-module (language ecmascript compile-ghil)
  23   #:use-module (language ghil)
  24   #:use-module (ice-9 receive)
  25   #:use-module (system base pmatch)
  26   #:export (compile-ghil))
  27
  28 (define-macro (-> form)
  29   `(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form)))
  30
  31 (define-macro (@implv sym)
  32   `(-> (ref (ghil-var-at-module! e '(language ecmascript impl) ',sym #t))))
  33 (define-macro (@impl sym args)
  34   `(-> (call (@implv ,sym) ,args)))
  35
  36 (define (compile-ghil exp env opts)
  37   (values
  38    (call-with-ghil-environment (make-ghil-toplevel-env) '()
  39      (lambda (e vars)
  40        (let ((l #f))
  41          (-> (lambda vars #f '()
  42                      (-> (begin (list (@impl js-init '())
  43                                       (comp exp e)))))))))
  44    env))
  45
  46 (define (location x)
  47   (and (pair? x)
  48        (let ((props (source-properties x)))
  49          (and (not (null? props))
  50               props))))
  51
  52 ;; The purpose, you ask? To avoid non-tail recursion when expanding a
  53 ;; long pmatch sequence.
  54 (define-macro (ormatch x . clauses)
  55   (let ((X (gensym)))
  56     `(let ((,X ,x))
  57        (or ,@(map (lambda (c)
  58                     (if (eq? (car c) 'else)
  59                         `(begin . ,(cdr c))
  60                         `(pmatch ,X ,c (else #f))))
  61                   clauses)))))
  62
  63 (define (comp x e)
  64   (let ((l (location x)))
  65     (define (let1 what proc)
  66       (call-with-ghil-bindings e '(%tmp)
  67         (lambda (vars)
  68           (-> (bind vars (list what)
  69                     (proc (car vars)))))))
  70     (define (begin1 what proc)
  71       (call-with-ghil-bindings e '(%tmp)
  72         (lambda (vars)
  73           (-> (bind vars (list what)
  74                     (-> (begin (list (proc (car vars))
  75                                      (-> (ref (car vars)))))))))))
  76     (ormatch x
  77       (null
  78        ;; FIXME, null doesn't have much relation to EOL...
  79        (-> (quote '())))
  80       (true
  81        (-> (quote #t)))
  82       (false
  83        (-> (quote #f)))
  84       ((number ,num)
  85        (-> (quote num)))
  86       ((string ,str)
  87        (-> (quote str)))
  88       (this
  89        (@impl get-this '()))
  90       ((+ ,a)
  91        (-> (inline 'add
  92                    (list (@impl ->number (list (comp a e)))
  93                          (-> (quote 0))))))
  94       ((- ,a)
  95        (-> (inline 'sub (list (-> (quote 0)) (comp a e)))))
  96       ((~ ,a)
  97        (@impl bitwise-not (list (comp a e))))
  98       ((! ,a)
  99        (@impl logical-not (list (comp a e))))
 100       ((+ ,a ,b)
 101        (-> (inline 'add (list (comp a e) (comp b e)))))
 102       ((- ,a ,b)
 103        (-> (inline 'sub (list (comp a e) (comp b e)))))
 104       ((/ ,a ,b)
 105        (-> (inline 'div (list (comp a e) (comp b e)))))
 106       ((* ,a ,b)
 107        (-> (inline 'mul (list (comp a e) (comp b e)))))
 108       ((% ,a ,b)
 109        (@impl mod (list (comp a e) (comp b e))))
 110       ((<< ,a ,b)
 111        (@impl shift (list (comp a e) (comp b e))))
 112       ((>> ,a ,b)
 113        (@impl shift (list (comp a e) (comp `(- ,b) e))))
 114       ((< ,a ,b)
 115        (-> (inline 'lt? (list (comp a e) (comp b e)))))
 116       ((<= ,a ,b)
 117        (-> (inline 'le? (list (comp a e) (comp b e)))))
 118       ((> ,a ,b)
 119        (-> (inline 'gt? (list (comp a e) (comp b e)))))
 120       ((>= ,a ,b)
 121        (-> (inline 'ge? (list (comp a e) (comp b e)))))
 122       ((in ,a ,b)
 123        (@impl has-property? (list (comp a e) (comp b e))))
 124       ((== ,a ,b)
 125        (-> (inline 'equal? (list (comp a e) (comp b e)))))
 126       ((!= ,a ,b)
 127        (-> (inline 'not
 128                    (list (-> (inline 'equal?
 129                                      (list (comp a e) (comp b e))))))))
 130       ((=== ,a ,b)
 131        (-> (inline 'eqv? (list (comp a e) (comp b e)))))
 132       ((!== ,a ,b)
 133        (-> (inline 'not
 134                    (list (-> (inline 'eqv?
 135                                      (list (comp a e) (comp b e))))))))
 136       ((& ,a ,b)
 137        (@impl band (list (comp a e) (comp b e))))
 138       ((^ ,a ,b)
 139        (@impl bxor (list (comp a e) (comp b e))))
 140       ((bor ,a ,b)
 141        (@impl bior (list (comp a e) (comp b e))))
 142       ((and ,a ,b)
 143        (-> (and (list (comp a e) (comp b e)))))
 144       ((or ,a ,b)
 145        (-> (or (list (comp a e) (comp b e)))))
 146       ((if ,test ,then ,else)
 147        (-> (if (@impl ->boolean (list (comp test e)))
 148                (comp then e)
 149                (comp else e))))
 150       ((if ,test ,then ,else)
 151        (-> (if (@impl ->boolean (list (comp test e)))
 152                (comp then e)
 153                (@implv *undefined*))))
 154       ((postinc (ref ,foo))
 155        (begin1 (comp `(ref ,foo) e)
 156                (lambda (var)
 157                  (-> (set (ghil-var-for-set! e foo)
 158                           (-> (inline 'add
 159                                       (list (-> (ref var))
 160                                             (-> (quote 1))))))))))
 161       ((postinc (pref ,obj ,prop))
 162        (let1 (comp obj e)
 163              (lambda (objvar)
 164                (begin1 (@impl pget
 165                               (list (-> (ref objvar))
 166                                     (-> (quote prop))))
 167                        (lambda (tmpvar)
 168                          (@impl pput
 169                                 (list (-> (ref objvar))
 170                                       (-> (quote prop))
 171                                       (-> (inline 'add
 172                                                   (list (-> (ref tmpvar))
 173                                                         (-> (quote 1))))))))))))
 174       ((postinc (aref ,obj ,prop))
 175        (let1 (comp obj e)
 176              (lambda (objvar)
 177                (let1 (comp prop e)
 178                      (lambda (propvar)
 179                        (begin1 (@impl pget
 180                                       (list (-> (ref objvar))
 181                                             (-> (ref propvar))))
 182                                (lambda (tmpvar)
 183                                  (@impl pput
 184                                         (list (-> (ref objvar))
 185                                               (-> (ref propvar))
 186                                               (-> (inline 'add
 187                                                           (list (-> (ref tmpvar))
 188                                                                 (-> (quote 1))))))))))))))
 189       ((postdec (ref ,foo))
 190        (begin1 (comp `(ref ,foo) e)
 191                (lambda (var)
 192                  (-> (set (ghil-var-for-set! e foo)
 193                           (-> (inline 'sub
 194                                       (list (-> (ref var))
 195                                             (-> (quote 1))))))))))
 196       ((postdec (pref ,obj ,prop))
 197        (let1 (comp obj e)
 198              (lambda (objvar)
 199                (begin1 (@impl pget
 200                               (list (-> (ref objvar))
 201                                     (-> (quote prop))))
 202                        (lambda (tmpvar)
 203                          (@impl pput
 204                                 (list (-> (ref objvar))
 205                                       (-> (quote prop))
 206                                       (-> (inline 'sub
 207                                                   (list (-> (ref tmpvar))
 208                                                         (-> (quote 1))))))))))))
 209       ((postdec (aref ,obj ,prop))
 210        (let1 (comp obj e)
 211              (lambda (objvar)
 212                (let1 (comp prop e)
 213                      (lambda (propvar)
 214                        (begin1 (@impl pget
 215                                       (list (-> (ref objvar))
 216                                             (-> (ref propvar))))
 217                                (lambda (tmpvar)
 218                                  (@impl pput
 219                                         (list (-> (ref objvar))
 220                                               (-> (ref propvar))
 221                                               (-> (inline
 222                                                    'sub (list (-> (ref tmpvar))
 223                                                               (-> (quote 1))))))))))))))
 224       ((preinc (ref ,foo))
 225        (let ((v (ghil-var-for-set! e foo)))
 226          (-> (begin
 227                (list
 228                 (-> (set v
 229                          (-> (inline 'add
 230                                      (list (-> (ref v))
 231                                            (-> (quote 1)))))))
 232                 (-> (ref v)))))))
 233       ((preinc (pref ,obj ,prop))
 234        (let1 (comp obj e)
 235              (lambda (objvar)
 236                (begin1 (-> (inline 'add
 237                                    (list (@impl pget
 238                                                 (list (-> (ref objvar))
 239                                                       (-> (quote prop))))
 240                                          (-> (quote 1)))))
 241                        (lambda (tmpvar)
 242                          (@impl pput (list (-> (ref objvar))
 243                                            (-> (quote prop))
 244                                            (-> (ref tmpvar)))))))))
 245       ((preinc (aref ,obj ,prop))
 246        (let1 (comp obj e)
 247              (lambda (objvar)
 248                (let1 (comp prop e)
 249                      (lambda (propvar)
 250                        (begin1 (-> (inline 'add
 251                                            (list (@impl pget
 252                                                         (list (-> (ref objvar))
 253                                                               (-> (ref propvar))))
 254                                                  (-> (quote 1)))))
 255                                (lambda (tmpvar)
 256                                  (@impl pput
 257                                         (list (-> (ref objvar))
 258                                               (-> (ref propvar))
 259                                               (-> (ref tmpvar)))))))))))
 260       ((predec (ref ,foo))
 261        (let ((v (ghil-var-for-set! e foo)))
 262          (-> (begin
 263                (list
 264                 (-> (set v
 265                          (-> (inline 'sub
 266                                      (list (-> (ref v))
 267                                            (-> (quote 1)))))))
 268                 (-> (ref v)))))))
 269       ((predec (pref ,obj ,prop))
 270        (let1 (comp obj e)
 271              (lambda (objvar)
 272                (begin1 (-> (inline 'sub
 273                                    (list (@impl pget
 274                                                 (list (-> (ref objvar))
 275                                                       (-> (quote prop))))
 276                                          (-> (quote 1)))))
 277                        (lambda (tmpvar)
 278                          (@impl pput
 279                                 (list (-> (ref objvar))
 280                                       (-> (quote prop))
 281                                       (-> (ref tmpvar)))))))))
 282       ((predec (aref ,obj ,prop))
 283        (let1 (comp obj e)
 284              (lambda (objvar)
 285                (let1 (comp prop e)
 286                      (lambda (propvar)
 287                        (begin1 (-> (inline 'sub
 288                                            (list (@impl pget
 289                                                         (list (-> (ref objvar))
 290                                                               (-> (ref propvar))))
 291                                                  (-> (quote 1)))))
 292                                (lambda (tmpvar)
 293                                  (@impl pput
 294                                         (list (-> (ref objvar))
 295                                               (-> (ref propvar))
 296                                               (-> (ref tmpvar)))))))))))
 297       ((ref ,id)
 298        (-> (ref (ghil-var-for-ref! e id))))
 299       ((var . ,forms)
 300        (-> (begin
 301              (map (lambda (form)
 302                     (pmatch form
 303                       ((,x ,y)
 304                        (-> (define (ghil-var-define! (ghil-env-parent e) x)
 305                                    (comp y e))))
 306                       ((,x)
 307                        (-> (define (ghil-var-define! (ghil-env-parent e) x)
 308                                    (@implv *undefined*))))
 309                       (else (error "bad var form" form))))
 310                   forms))))
 311       ((begin . ,forms)
 312        (-> (begin
 313              (map (lambda (x) (comp x e)) forms))))
 314       ((lambda ,formals ,body)
 315        (call-with-ghil-environment e '(%args)
 316          (lambda (e vars)
 317            (-> (lambda vars #t '()
 318                        (comp-body env l body formals '%args))))))
 319       ((call/this ,obj ,prop ,args)
 320        (@impl call/this*
 321               (list obj
 322                     (-> (lambda '() #f '()
 323                                 (-> (call (@impl pget (list obj prop))
 324                                           args)))))))
 325       ((call (pref ,obj ,prop) ,args)
 326        (comp `(call/this ,(comp obj e)
 327                          ,(-> (quote prop))
 328                          ,(map (lambda (x) (comp x e)) args))
 329              e))
 330       ((call (aref ,obj ,prop) ,args)
 331        (comp `(call/this ,(comp obj e)
 332                          ,(comp prop e)
 333                          ,(map (lambda (x) (comp x e)) args))
 334              e))
 335       ((call ,proc ,args)
 336        (-> (call (comp proc e)
 337                  (map (lambda (x) (comp x e)) args))))
 338       ((return ,expr)
 339        (-> (inline 'return
 340                    (list (comp expr e)))))
 341       ((array . ,args)
 342        (@impl new-array
 343               (map (lambda (x) (comp x e)) args)))
 344       ((object . ,args)
 345        (@impl new-object
 346               (map (lambda (x)
 347                      (pmatch x
 348                        ((,prop ,val)
 349                         (-> (inline 'cons
 350                                     (list (-> (quote prop))
 351                                           (comp val e)))))
 352                        (else
 353                         (error "bad prop-val pair" x))))
 354                    args)))
 355       ((pref ,obj ,prop)
 356        (@impl pget
 357               (list (comp obj e)
 358                     (-> (quote prop)))))
 359       ((aref ,obj ,index)
 360        (@impl pget
 361               (list (comp obj e)
 362                     (comp index e))))
 363       ((= (ref ,name) ,val)
 364        (let ((v (ghil-var-for-set! e name)))
 365          (-> (begin
 366                (list (-> (set v (comp val e)))
 367                      (-> (ref v)))))))
 368       ((= (pref ,obj ,prop) ,val)
 369        (@impl pput
 370               (list (comp obj e)
 371                     (-> (quote prop))
 372                     (comp val e))))
 373       ((= (aref ,obj ,prop) ,val)
 374        (@impl pput
 375               (list (comp obj e)
 376                     (comp prop e)
 377                     (comp val e))))
 378       ((+= ,what ,val)
 379        (comp `(= ,what (+ ,what ,val)) e))
 380       ((-= ,what ,val)
 381        (comp `(= ,what (- ,what ,val)) e))
 382       ((/= ,what ,val)
 383        (comp `(= ,what (/ ,what ,val)) e))
 384       ((*= ,what ,val)
 385        (comp `(= ,what (* ,what ,val)) e))
 386       ((%= ,what ,val)
 387        (comp `(= ,what (% ,what ,val)) e))
 388       ((>>= ,what ,val)
 389        (comp `(= ,what (>> ,what ,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       ((bor= ,what ,val)
 397        (comp `(= ,what (bor ,what ,val)) e))
 398       ((^= ,what ,val)
 399        (comp `(= ,what (^ ,what ,val)) e))
 400       ((new ,what ,args)
 401        (@impl new
 402               (map (lambda (x) (comp x e))
 403                    (cons what args))))
 404       ((delete (pref ,obj ,prop))
 405        (@impl pdel
 406               (list (comp obj e)
 407                     (-> (quote prop)))))
 408       ((delete (aref ,obj ,prop))
 409        (@impl pdel
 410               (list (comp obj e)
 411                     (comp prop e))))
 412       ((void ,expr)
 413        (-> (begin
 414              (list (comp expr e)
 415                    (@implv *undefined*)))))
 416       ((typeof ,expr)
 417        (@impl typeof
 418               (list (comp expr e))))
 419       ((do ,statement ,test)
 420        (call-with-ghil-bindings e '(%loop %continue)
 421          (lambda (vars)
 422            (-> (bind vars
 423                      (list (call-with-ghil-environment e '()
 424                              (lambda (e _)
 425                                (-> (lambda '() #f '()
 426                                      (-> (begin
 427                                            (list (comp statement e)
 428                                                  (-> (call
 429                                                       (-> (ref (ghil-var-for-ref! e '%continue)))
 430                                                       '())))))))))
 431                            (call-with-ghil-environment e '()
 432                              (lambda (e _)
 433                                (-> (lambda '() #f '()
 434                                      (-> (if (@impl ->boolean (list (comp test e)))
 435                                              (-> (call
 436                                                   (-> (ref (ghil-var-for-ref! e '%loop)))
 437                                                   '()))
 438                                              (@implv *undefined*))))))))
 439                      (-> (call (-> (ref (car vars))) '())))))))
 440       ((while ,test ,statement)
 441        (call-with-ghil-bindings e '(%continue)
 442          (lambda (vars)
 443            (-> (begin
 444                  (list
 445                   (-> (set (car vars)
 446                            (call-with-ghil-environment e '()
 447                              (lambda (e _)
 448                                (-> (lambda '() #f '()
 449                                      (-> (if (@impl ->boolean (list (comp test e)))
 450                                              (-> (begin
 451                                                    (list (comp statement e)
 452                                                          (-> (call
 453                                                               (-> (ref (ghil-var-for-ref! e '%continue)))
 454                                                               '())))))
 455                                              (@implv *undefined*)))))))))
 456                   (-> (call (-> (ref (car vars))) '()))))))))
 457       ((for ,init ,test ,inc ,statement)
 458        (call-with-ghil-bindings e '(%continue)
 459          (lambda (vars)
 460            (-> (begin
 461                  (list
 462                   (comp (or init '(begin)) e)
 463                   (-> (set (car vars)
 464                            (call-with-ghil-environment e '()
 465                              (lambda (e _)
 466                                (-> (lambda '() #f '()
 467                                      (-> (if (if test
 468                                                  (@impl ->boolean (list (comp test e)))
 469                                                  (comp 'true e))
 470                                              (-> (begin
 471                                                    (list (comp statement e)
 472                                                          (comp (or inc '(begin)) e)
 473                                                          (-> (call
 474                                                               (-> (ref (ghil-var-for-ref! e '%continue)))
 475                                                               '())))))
 476                                              (@implv *undefined*)))))))))
 477                   (-> (call (-> (ref (car vars))) '()))))))))
 478       ((for-in ,var ,object ,statement)
 479        (call-with-ghil-bindings e '(%continue %enum)
 480          (lambda (vars)
 481            (-> (begin
 482                  (list
 483                   (-> (set (car vars)
 484                            (call-with-ghil-environment e '()
 485                              (lambda (e _)
 486                                (-> (lambda '() #f '()
 487                                      (-> (if (@impl ->boolean
 488                                                     (list (@impl pget
 489                                                                  (list (-> (ref (ghil-var-for-ref! e '%enum)))
 490                                                                        (-> (quote 'length))))))
 491                                              (-> (begin
 492                                                    (list
 493                                                     (comp `(= ,var (call/this ,(-> (ref (ghil-var-for-ref! e '%enum)))
 494                                                                               ,(-> (quote 'pop))
 495                                                                               ()))
 496                                                           e)
 497                                                     (comp statement e)
 498                                                     (-> (call (-> (ref (ghil-var-for-ref! e '%continue)))
 499                                                               '())))))
 500                                              (@implv *undefined*)))))))))
 501                   (-> (set (cadr vars)
 502                            (@impl make-enumerator (list (comp object e)))))
 503                   (-> (call (-> (ref (car vars))) '()))))))))
 504       ((break)
 505        (let ((var (ghil-var-for-ref! e '%continue)))
 506          (if (and (ghil-env? (ghil-var-env var))
 507                   (eq? (ghil-var-env var) (ghil-env-parent e)))
 508              (-> (inline 'return (@implv *undefined*)))
 509              (error "bad break, yo"))))
 510       ((continue)
 511        (let ((var (ghil-var-for-ref! e '%continue)))
 512          (if (and (ghil-env? (ghil-var-env var))
 513                   (eq? (ghil-var-env var) (ghil-env-parent e)))
 514              (-> (inline 'goto/args (list (-> (ref var)))))
 515              (error "bad continue, yo"))))
 516       ((block ,x)
 517        (comp x e))
 518       (else
 519        (error "compilation not yet implemented:" x)))))
 520
 521 (define (comp-body e l body formals %args)
 522   (define (process)
 523     (let lp ((in body) (out '()) (rvars (reverse formals)))
 524       (pmatch in
 525         (((var (,x) . ,morevars) . ,rest)
 526          (lp `((var . ,morevars) . ,rest)
 527              out
 528              (if (memq x rvars) rvars (cons x rvars))))
 529         (((var (,x ,y) . ,morevars) . ,rest)
 530          (lp `((var . ,morevars) . ,rest)
 531              `((= (ref ,x) ,y) . ,out)
 532              (if (memq x rvars) rvars (cons x rvars))))
 533         (((var) . ,rest)
 534          (lp rest out rvars))
 535         ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
 536          (lp rest
 537              (cons x out)
 538              rvars))
 539         ((,x . ,rest) (guard (pair? x))
 540          (receive (sub-out rvars)
 541              (lp x '() rvars)
 542            (lp rest
 543                (cons sub-out out)
 544                rvars)))
 545         ((,x . ,rest)
 546          (lp rest
 547              (cons x out)
 548              rvars))
 549         (()
 550          (values (reverse! out)
 551                  rvars)))))
 552   (receive (out rvars)
 553       (process)
 554     (call-with-ghil-bindings e (reverse rvars)
 555       (lambda (vars)
 556         (let ((%argv (assq-ref (ghil-env-table e) %args)))
 557           (-> (begin
 558                 `(,@(map
 559                      (lambda (f)
 560                        (-> (if (-> (inline 'null?
 561                                            (list (-> (ref %argv)))))
 562                                (-> (begin '()))
 563                                (-> (begin
 564                                      (list (-> (set (ghil-var-for-ref! e f)
 565                                                     (-> (inline 'car
 566                                                                 (list (-> (ref %argv)))))))
 567                                            (-> (set %argv
 568                                                     (-> (inline 'cdr
 569                                                                 (list (-> (ref %argv)))))))))))))
 570                      formals)
 571                   ;; fixme: here check for too many args
 572                   ,(comp out e)))))))))