src/compiler.lisp

   1 ;;; compiler.lisp ---
   2
   3 ;; Copyright (C) 2012, 2013 David Vazquez
   4 ;; Copyright (C) 2012 Raimon Grau
   5
   6 ;; JSCL is free software: you can redistribute it and/or
   7 ;; modify it under the terms of the GNU General Public License as
   8 ;; published by the Free Software Foundation, either version 3 of the
   9 ;; License, or (at your option) any later version.
  10 ;;
  11 ;; JSCL is distributed in the hope that it will be useful, but
  12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;; General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License
  17 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;;;; Compiler
  20
  21 (/debug "loading compiler.lisp!")
  22
  23 (define-js-macro selfcall (&body body)
  24   `(call (function () ,@body)))
  25
  26 (define-js-macro bool (expr)
  27   `(if ,expr ,(convert t) ,(convert nil)))
  28
  29 (define-js-macro method-call (x method &rest args)
  30   `(call (get ,x ,method) ,@args))
  31
  32 ;;; Translate the Lisp code to Javascript. It will compile the special
  33 ;;; forms. Some primitive functions are compiled as special forms
  34 ;;; too. The respective real functions are defined in the target (see
  35 ;;; the beginning of this file) as well as some primitive functions.
  36
  37 (defun interleave (list element &optional after-last-p)
  38   (unless (null list)
  39     (with-collect
  40       (collect (car list))
  41       (dolist (x (cdr list))
  42         (collect element)
  43         (collect x))
  44       (when after-last-p
  45         (collect element)))))
  46
  47 ;;; Like CODE, but prefix each line with four spaces. Two versions
  48 ;;; of this function are available, because the Ecmalisp version is
  49 ;;; very slow and bootstraping was annoying.
  50
  51 ;;; A Form can return a multiple values object calling VALUES, like
  52 ;;; values(arg1, arg2, ...). It will work in any context, as well as
  53 ;;; returning an individual object. However, if the special variable
  54 ;;; `*multiple-value-p*' is NIL, is granted that only the primary
  55 ;;; value will be used, so we can optimize to avoid the VALUES
  56 ;;; function call.
  57 (defvar *multiple-value-p* nil)
  58
  59 ;;; Environment
  60
  61 (def!struct binding
  62   name
  63   type
  64   value
  65   declarations)
  66
  67 (def!struct lexenv
  68   variable
  69   function
  70   block
  71   gotag)
  72
  73 (defun lookup-in-lexenv (name lexenv namespace)
  74   (find name (ecase namespace
  75                 (variable (lexenv-variable lexenv))
  76                 (function (lexenv-function lexenv))
  77                 (block    (lexenv-block    lexenv))
  78                 (gotag    (lexenv-gotag    lexenv)))
  79         :key #'binding-name))
  80
  81 (defun push-to-lexenv (binding lexenv namespace)
  82   (ecase namespace
  83     (variable (push binding (lexenv-variable lexenv)))
  84     (function (push binding (lexenv-function lexenv)))
  85     (block    (push binding (lexenv-block    lexenv)))
  86     (gotag    (push binding (lexenv-gotag    lexenv)))))
  87
  88 (defun extend-lexenv (bindings lexenv namespace)
  89   (let ((env (copy-lexenv lexenv)))
  90     (dolist (binding (reverse bindings) env)
  91       (push-to-lexenv binding env namespace))))
  92
  93
  94 (defvar *environment* (make-lexenv))
  95 (defvar *variable-counter* 0)
  96
  97 (defun gvarname (symbol)
  98   (declare (ignore symbol))
  99   (incf *variable-counter*)
 100   (make-symbol (concat "v" (integer-to-string *variable-counter*))))
 101
 102 (defun translate-variable (symbol)
 103   (awhen (lookup-in-lexenv symbol *environment* 'variable)
 104     (binding-value it)))
 105
 106 (defun extend-local-env (args)
 107   (let ((new (copy-lexenv *environment*)))
 108     (dolist (symbol args new)
 109       (let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol))))
 110         (push-to-lexenv b new 'variable)))))
 111
 112 ;;; Toplevel compilations
 113 (defvar *toplevel-compilations* nil)
 114
 115 (defun toplevel-compilation (string)
 116   (push string *toplevel-compilations*))
 117
 118 (defun get-toplevel-compilations ()
 119   (reverse *toplevel-compilations*))
 120
 121 (defun %compile-defmacro (name lambda)
 122   (toplevel-compilation (convert `',name))
 123   (let ((binding (make-binding :name name :type 'macro :value lambda)))
 124     (push-to-lexenv binding  *environment* 'function))
 125   name)
 126
 127 (defun global-binding (name type namespace)
 128   (or (lookup-in-lexenv name *environment* namespace)
 129       (let ((b (make-binding :name name :type type :value nil)))
 130         (push-to-lexenv b *environment* namespace)
 131         b)))
 132
 133 (defun claimp (symbol namespace claim)
 134   (let ((b (lookup-in-lexenv symbol *environment* namespace)))
 135     (and b (member claim (binding-declarations b)))))
 136
 137 (defun !proclaim (decl)
 138   (case (car decl)
 139     (special
 140      (dolist (name (cdr decl))
 141        (let ((b (global-binding name 'variable 'variable)))
 142          (push 'special (binding-declarations b)))))
 143     (notinline
 144      (dolist (name (cdr decl))
 145        (let ((b (global-binding name 'function 'function)))
 146          (push 'notinline (binding-declarations b)))))
 147     (constant
 148      (dolist (name (cdr decl))
 149        (let ((b (global-binding name 'variable 'variable)))
 150          (push 'constant (binding-declarations b)))))))
 151
 152 #+jscl
 153 (fset 'proclaim #'!proclaim)
 154
 155 (defun %define-symbol-macro (name expansion)
 156   (let ((b (make-binding :name name :type 'macro :value expansion)))
 157     (push-to-lexenv b *environment* 'variable)
 158     name))
 159
 160 #+jscl
 161 (defmacro define-symbol-macro (name expansion)
 162   `(%define-symbol-macro ',name ',expansion))
 163
 164
 165 ;;; Special forms
 166
 167 (defvar *compilations* nil)
 168
 169 (defmacro define-compilation (name args &body body)
 170   ;; Creates a new primitive `name' with parameters args and
 171   ;; @body. The body can access to the local environment through the
 172   ;; variable *ENVIRONMENT*.
 173   `(push (list ',name (lambda ,args (block ,name ,@body)))
 174          *compilations*))
 175
 176 (define-compilation if (condition true &optional false)
 177   `(if (!== ,(convert condition) ,(convert nil))
 178        ,(convert true *multiple-value-p*)
 179        ,(convert false *multiple-value-p*)))
 180
 181 (defvar *ll-keywords* '(&optional &rest &key))
 182
 183 (defun list-until-keyword (list)
 184   (if (or (null list) (member (car list) *ll-keywords*))
 185       nil
 186       (cons (car list) (list-until-keyword (cdr list)))))
 187
 188 (defun ll-section (keyword ll)
 189   (list-until-keyword (cdr (member keyword ll))))
 190
 191 (defun ll-required-arguments (ll)
 192   (list-until-keyword ll))
 193
 194 (defun ll-optional-arguments-canonical (ll)
 195   (mapcar #'ensure-list (ll-section '&optional ll)))
 196
 197 (defun ll-optional-arguments (ll)
 198   (mapcar #'car (ll-optional-arguments-canonical ll)))
 199
 200 (defun ll-rest-argument (ll)
 201   (let ((rest (ll-section '&rest ll)))
 202     (when (cdr rest)
 203       (error "Bad lambda-list `~S'." ll))
 204     (car rest)))
 205
 206 (defun ll-keyword-arguments-canonical (ll)
 207   (flet ((canonicalize (keyarg)
 208            ;; Build a canonical keyword argument descriptor, filling
 209            ;; the optional fields. The result is a list of the form
 210            ;; ((keyword-name var) init-form svar).
 211            (let ((arg (ensure-list keyarg)))
 212              (cons (if (listp (car arg))
 213                        (car arg)
 214                        (list (intern (symbol-name (car arg)) "KEYWORD") (car arg)))
 215                    (cdr arg)))))
 216     (mapcar #'canonicalize (ll-section '&key ll))))
 217
 218 (defun ll-keyword-arguments (ll)
 219   (mapcar (lambda (keyarg) (second (first keyarg)))
 220           (ll-keyword-arguments-canonical ll)))
 221
 222 (defun ll-svars (lambda-list)
 223   (let ((args
 224          (append
 225           (ll-keyword-arguments-canonical lambda-list)
 226           (ll-optional-arguments-canonical lambda-list))))
 227     (remove nil (mapcar #'third args))))
 228
 229 (defun lambda-name/docstring-wrapper (name docstring code)
 230   (if (or name docstring)
 231       `(selfcall
 232         (var (func ,code))
 233         ,(when name `(= (get func "fname") ,name))
 234         ,(when docstring `(= (get func "docstring") ,docstring))
 235         (return func))
 236       code))
 237
 238 (defun lambda-check-argument-count
 239     (n-required-arguments n-optional-arguments rest-p)
 240   ;; Note: Remember that we assume that the number of arguments of a
 241   ;; call is at least 1 (the values argument).
 242   (let ((min n-required-arguments)
 243         (max (if rest-p 'n/a (+ n-required-arguments n-optional-arguments))))
 244     (block nil
 245       ;; Special case: a positive exact number of arguments.
 246       (when (and (< 0 min) (eql min max))
 247         (return `(call |checkArgs| |nargs| ,min)))
 248       ;; General case:
 249       `(progn
 250          ,(when (< 0 min)     `(call |checkArgsAtLeast| |nargs| ,min))
 251          ,(when (numberp max) `(call |checkArgsAtMost|  |nargs| ,max))))))
 252
 253 (defun compile-lambda-optional (ll)
 254   (let* ((optional-arguments (ll-optional-arguments-canonical ll))
 255          (n-required-arguments (length (ll-required-arguments ll)))
 256          (n-optional-arguments (length optional-arguments)))
 257     (when optional-arguments
 258       `(switch |nargs|
 259                ,@(with-collect
 260                   (dotimes (idx n-optional-arguments)
 261                     (let ((arg (nth idx optional-arguments)))
 262                       (collect `(case ,(+ idx n-required-arguments)))
 263                       (collect `(= ,(translate-variable (car arg))
 264                                    ,(convert (cadr arg))))
 265                       (collect (when (third arg)
 266                                  `(= ,(translate-variable (third arg))
 267                                      ,(convert nil))))))
 268                   (collect 'default)
 269                   (collect '(break)))))))
 270
 271 (defun compile-lambda-rest (ll)
 272   (let ((n-required-arguments (length (ll-required-arguments ll)))
 273         (n-optional-arguments (length (ll-optional-arguments ll)))
 274         (rest-argument (ll-rest-argument ll)))
 275     (when rest-argument
 276       (let ((js!rest (translate-variable rest-argument)))
 277         `(progn
 278            (var (,js!rest ,(convert nil)))
 279            (var i)
 280            (for ((= i (- |nargs| 1))
 281                  (>= i ,(+ n-required-arguments n-optional-arguments))
 282                  (post-- i))
 283                 (= ,js!rest (object "car" (property |arguments| (+ i 2))
 284                                     "cdr" ,js!rest))))))))
 285
 286 (defun compile-lambda-parse-keywords (ll)
 287   (let ((n-required-arguments
 288          (length (ll-required-arguments ll)))
 289         (n-optional-arguments
 290          (length (ll-optional-arguments ll)))
 291         (keyword-arguments
 292          (ll-keyword-arguments-canonical ll)))
 293     `(progn
 294        ;; Declare variables
 295        ,@(with-collect
 296           (dolist (keyword-argument keyword-arguments)
 297             (destructuring-bind ((keyword-name var) &optional initform svar)
 298                 keyword-argument
 299               (declare (ignore keyword-name initform))
 300               (collect `(var ,(translate-variable var)))
 301               (when svar
 302                 (collect
 303                     `(var (,(translate-variable svar)
 304                             ,(convert nil))))))))
 305
 306        ;; Parse keywords
 307        ,(flet ((parse-keyword (keyarg)
 308                 (destructuring-bind ((keyword-name var) &optional initform svar) keyarg
 309                   ;; ((keyword-name var) init-form svar)
 310                   `(progn
 311                      (for ((= i ,(+ n-required-arguments n-optional-arguments))
 312                            (< i |nargs|)
 313                            (+= i 2))
 314                           ;; ....
 315                           (if (=== (property |arguments| (+ i 2))
 316                                    ,(convert keyword-name))
 317                               (progn
 318                                 (= ,(translate-variable var)
 319                                    (property |arguments| (+ i 3)))
 320                                 ,(when svar `(= ,(translate-variable svar)
 321                                                 ,(convert t)))
 322                                 (break))))
 323                      (if (== i |nargs|)
 324                          (= ,(translate-variable var) ,(convert initform)))))))
 325          (when keyword-arguments
 326            `(progn
 327               (var i)
 328               ,@(mapcar #'parse-keyword keyword-arguments))))
 329
 330        ;; Check for unknown keywords
 331        ,(when keyword-arguments
 332          `(progn
 333             (var (start ,(+ n-required-arguments n-optional-arguments)))
 334             (if (== (% (- |nargs| start) 2) 1)
 335                 (throw "Odd number of keyword arguments."))
 336             (for ((= i start) (< i |nargs|) (+= i 2))
 337                  (if (and ,@(mapcar (lambda (keyword-argument)
 338                                  (destructuring-bind ((keyword-name var) &optional initform svar)
 339                                      keyword-argument
 340                                    (declare (ignore var initform svar))
 341                                    `(!== (property |arguments| (+ i 2)) ,(convert keyword-name))))
 342                                keyword-arguments))
 343                      (throw (+ "Unknown keyword argument "
 344                                (call |xstring|
 345                                      (property
 346                                       (property |arguments| (+ i 2))
 347                                       "name")))))))))))
 348
 349 (defun parse-lambda-list (ll)
 350   (values (ll-required-arguments ll)
 351           (ll-optional-arguments ll)
 352           (ll-keyword-arguments  ll)
 353           (ll-rest-argument      ll)))
 354
 355 ;;; Process BODY for declarations and/or docstrings. Return as
 356 ;;; multiple values the BODY without docstrings or declarations, the
 357 ;;; list of declaration forms and the docstring.
 358 (defun parse-body (body &key declarations docstring)
 359   (let ((value-declarations)
 360         (value-docstring))
 361     ;; Parse declarations
 362     (when declarations
 363       (do* ((rest body (cdr rest))
 364             (form (car rest) (car rest)))
 365            ((or (atom form) (not (eq (car form) 'declare)))
 366             (setf body rest))
 367         (push form value-declarations)))
 368     ;; Parse docstring
 369     (when (and docstring
 370                (stringp (car body))
 371                (not (null (cdr body))))
 372       (setq value-docstring (car body))
 373       (setq body (cdr body)))
 374     (values body value-declarations value-docstring)))
 375
 376 ;;; Compile a lambda function with lambda list LL and body BODY. If
 377 ;;; NAME is given, it should be a constant string and it will become
 378 ;;; the name of the function. If BLOCK is non-NIL, a named block is
 379 ;;; created around the body. NOTE: No block (even anonymous) is
 380 ;;; created if BLOCk is NIL.
 381 (defun compile-lambda (ll body &key name block)
 382   (multiple-value-bind (required-arguments
 383                         optional-arguments
 384                         keyword-arguments
 385                         rest-argument)
 386       (parse-lambda-list ll)
 387     (multiple-value-bind (body decls documentation)
 388         (parse-body body :declarations t :docstring t)
 389       (declare (ignore decls))
 390       (let ((n-required-arguments (length required-arguments))
 391             (n-optional-arguments (length optional-arguments))
 392             (*environment* (extend-local-env
 393                             (append (ensure-list rest-argument)
 394                                     required-arguments
 395                                     optional-arguments
 396                                     keyword-arguments
 397                                     (ll-svars ll)))))
 398         (lambda-name/docstring-wrapper name documentation
 399          `(function (|values| |nargs| ,@(mapcar (lambda (x)
 400                                                   (translate-variable x))
 401                                                 (append required-arguments optional-arguments)))
 402                      ;; Check number of arguments
 403                     ,(lambda-check-argument-count n-required-arguments
 404                                                   n-optional-arguments
 405                                                   (or rest-argument keyword-arguments))
 406                     ,(compile-lambda-optional ll)
 407                     ,(compile-lambda-rest ll)
 408                     ,(compile-lambda-parse-keywords ll)
 409
 410                     ,(let ((*multiple-value-p* t))
 411                           (if block
 412                               (convert-block `((block ,block ,@body)) t)
 413                               (convert-block body t)))))))))
 414
 415
 416 (defun setq-pair (var val)
 417   (let ((b (lookup-in-lexenv var *environment* 'variable)))
 418     (cond
 419       ((and b
 420             (eq (binding-type b) 'variable)
 421             (not (member 'special (binding-declarations b)))
 422             (not (member 'constant (binding-declarations b))))
 423        ;; TODO: Unnecesary make-symbol when codegen migration is
 424        ;; finished.
 425        `(= ,(binding-value b) ,(convert val)))
 426       ((and b (eq (binding-type b) 'macro))
 427        (convert `(setf ,var ,val)))
 428       (t
 429        (convert `(set ',var ,val))))))
 430
 431
 432 (define-compilation setq (&rest pairs)
 433   (let ((result nil))
 434     (when (null pairs)
 435       (return-from setq (convert nil)))
 436     (while t
 437       (cond
 438         ((null pairs)
 439          (return))
 440         ((null (cdr pairs))
 441          (error "Odd pairs in SETQ"))
 442         (t
 443          (push `,(setq-pair (car pairs) (cadr pairs)) result)
 444          (setq pairs (cddr pairs)))))
 445     `(progn ,@(reverse result))))
 446
 447
 448 ;;; Compilation of literals an object dumping
 449
 450 ;;; BOOTSTRAP MAGIC: We record the macro definitions as lists during
 451 ;;; the bootstrap. Once everything is compiled, we want to dump the
 452 ;;; whole global environment to the output file to reproduce it in the
 453 ;;; run-time. However, the environment must contain expander functions
 454 ;;; rather than lists. We do not know how to dump function objects
 455 ;;; itself, so we mark the list definitions with this object and the
 456 ;;; compiler will be called when this object has to be dumped.
 457 ;;; Backquote/unquote does a similar magic, but this use is exclusive.
 458 ;;;
 459 ;;; Indeed, perhaps to compile the object other macros need to be
 460 ;;; evaluated. For this reason we define a valid macro-function for
 461 ;;; this symbol.
 462 (defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE"))
 463
 464 #-jscl
 465 (setf (macro-function *magic-unquote-marker*)
 466       (lambda (form &optional environment)
 467         (declare (ignore environment))
 468         (second form)))
 469
 470 (defvar *literal-table* nil)
 471 (defvar *literal-counter* 0)
 472
 473 (defun genlit ()
 474   (incf *literal-counter*)
 475   (make-symbol (concat "l" (integer-to-string *literal-counter*))))
 476
 477 (defun dump-symbol (symbol)
 478   #-jscl
 479   (let ((package (symbol-package symbol)))
 480     (if (eq package (find-package "KEYWORD"))
 481         `(new (call |Symbol| ,(dump-string (symbol-name symbol)) ,(dump-string (package-name package))))
 482         `(new (call |Symbol| ,(dump-string (symbol-name symbol))))))
 483   #+jscl
 484   (let ((package (symbol-package symbol)))
 485     (if (null package)
 486         `(new (call |Symbol| ,(dump-string (symbol-name symbol))))
 487         (convert `(intern ,(symbol-name symbol) ,(package-name package))))))
 488
 489 (defun dump-cons (cons)
 490   (let ((head (butlast cons))
 491         (tail (last cons)))
 492     `(call |QIList|
 493            ,@(mapcar (lambda (x) (literal x t)) head)
 494            ,(literal (car tail) t)
 495            ,(literal (cdr tail) t))))
 496
 497 (defun dump-array (array)
 498   (let ((elements (vector-to-list array)))
 499     (list-to-vector (mapcar #'literal elements))))
 500
 501 (defun dump-string (string)
 502   `(call |make_lisp_string| ,string))
 503
 504 (defun literal (sexp &optional recursive)
 505   (cond
 506     ((integerp sexp) sexp)
 507     ((floatp sexp) sexp)
 508     ((characterp sexp)
 509      ;; TODO: Remove selfcall after migration
 510      `(selfcall (return ,(string sexp))))
 511     (t
 512      (or (cdr (assoc sexp *literal-table* :test #'eql))
 513          (let ((dumped (typecase sexp
 514                          (symbol (dump-symbol sexp))
 515                          (string (dump-string sexp))
 516                          (cons
 517                           ;; BOOTSTRAP MAGIC: See the root file
 518                           ;; jscl.lisp and the function
 519                           ;; `dump-global-environment' for futher
 520                           ;; information.
 521                           (if (eq (car sexp) *magic-unquote-marker*)
 522                               (convert (second sexp))
 523                               (dump-cons sexp)))
 524                          (array (dump-array sexp)))))
 525            (if (and recursive (not (symbolp sexp)))
 526                dumped
 527                (let ((jsvar (genlit)))
 528                  (push (cons sexp jsvar) *literal-table*)
 529                  (toplevel-compilation `(var (,jsvar ,dumped)))
 530                  (when (keywordp sexp)
 531                    (toplevel-compilation `(= ,(get jsvar "value") ,jsvar)))
 532                  jsvar)))))))
 533
 534
 535 (define-compilation quote (sexp)
 536   (literal sexp))
 537
 538 (define-compilation %while (pred &rest body)
 539   `(selfcall
 540     (while (!== ,(convert pred) ,(convert nil))
 541       0                                 ; TODO: Force
 542                                         ; braces. Unnecesary when code
 543                                         ; is gone
 544       ,(convert-block body))
 545     (return ,(convert nil))))
 546
 547 (define-compilation function (x)
 548   (cond
 549     ((and (listp x) (eq (car x) 'lambda))
 550      (compile-lambda (cadr x) (cddr x)))
 551     ((and (listp x) (eq (car x) 'named-lambda))
 552      (destructuring-bind (name ll &rest body) (cdr x)
 553        (compile-lambda ll body
 554                        :name (symbol-name name)
 555                        :block name)))
 556     ((symbolp x)
 557      (let ((b (lookup-in-lexenv x *environment* 'function)))
 558        (if b
 559            (binding-value b)
 560            (convert `(symbol-function ',x)))))))
 561
 562 (defun make-function-binding (fname)
 563   (make-binding :name fname :type 'function :value (gvarname fname)))
 564
 565 (defun compile-function-definition (list)
 566   (compile-lambda (car list) (cdr list)))
 567
 568 (defun translate-function (name)
 569   (let ((b (lookup-in-lexenv name *environment* 'function)))
 570     (and b (binding-value b))))
 571
 572 (define-compilation flet (definitions &rest body)
 573   (let* ((fnames (mapcar #'car definitions))
 574          (cfuncs (mapcar (lambda (def)
 575                            (compile-lambda (cadr def)
 576                                            `((block ,(car def)
 577                                                ,@(cddr def)))))
 578                          definitions))
 579          (*environment*
 580           (extend-lexenv (mapcar #'make-function-binding fnames)
 581                          *environment*
 582                          'function)))
 583     `(call (function ,(mapcar #'translate-function fnames)
 584                 ,(convert-block body t))
 585            ,@cfuncs)))
 586
 587 (define-compilation labels (definitions &rest body)
 588   (let* ((fnames (mapcar #'car definitions))
 589          (*environment*
 590           (extend-lexenv (mapcar #'make-function-binding fnames)
 591                          *environment*
 592                          'function)))
 593     `(selfcall
 594       ,@(mapcar (lambda (func)
 595                   `(var (,(translate-function (car func))
 596                           ,(compile-lambda (cadr func)
 597                                            `((block ,(car func) ,@(cddr func)))))))
 598                 definitions)
 599       ,(convert-block body t))))
 600
 601
 602 (defvar *compiling-file* nil)
 603 (define-compilation eval-when-compile (&rest body)
 604   (if *compiling-file*
 605       (progn
 606         (eval (cons 'progn body))
 607         (convert 0))
 608       (convert `(progn ,@body))))
 609
 610 (defmacro define-transformation (name args form)
 611   `(define-compilation ,name ,args
 612      (convert ,form)))
 613
 614 (define-compilation progn (&rest body)
 615   (if (null (cdr body))
 616       (convert (car body) *multiple-value-p*)
 617       `(progn
 618          ,@(append (mapcar #'convert (butlast body))
 619                    (list (convert (car (last body)) t))))))
 620
 621 (define-compilation macrolet (definitions &rest body)
 622   (let ((*environment* (copy-lexenv *environment*)))
 623     (dolist (def definitions)
 624       (destructuring-bind (name lambda-list &body body) def
 625         (let ((binding (make-binding :name name :type 'macro :value
 626                                      (let ((g!form (gensym)))
 627                                        `(lambda (,g!form)
 628                                           (destructuring-bind ,lambda-list ,g!form
 629                                             ,@body))))))
 630           (push-to-lexenv binding  *environment* 'function))))
 631     (convert `(progn ,@body) *multiple-value-p*)))
 632
 633
 634 (defun special-variable-p (x)
 635   (and (claimp x 'variable 'special) t))
 636
 637 ;;; Wrap CODE to restore the symbol values of the dynamic
 638 ;;; bindings. BINDINGS is a list of pairs of the form
 639 ;;; (SYMBOL . PLACE),  where PLACE is a Javascript variable
 640 ;;; name to initialize the symbol value and where to stored
 641 ;;; the old value.
 642 (defun let-binding-wrapper (bindings body)
 643   (when (null bindings)
 644     (return-from let-binding-wrapper body))
 645   `(progn
 646      (try (var tmp)
 647           ,@(with-collect
 648              (dolist (b bindings)
 649                (let ((s (convert `',(car b))))
 650                  (collect `(= tmp (get ,s "value")))
 651                  (collect `(= (get ,s "value") ,(cdr b)))
 652                  (collect `(= ,(cdr b) tmp)))))
 653           ,body)
 654      (finally
 655       ,@(with-collect
 656          (dolist (b bindings)
 657            (let ((s (convert `(quote ,(car b)))))
 658              (collect `(= (get ,s "value") ,(cdr b)))))))))
 659
 660 (define-compilation let (bindings &rest body)
 661   (let* ((bindings (mapcar #'ensure-list bindings))
 662          (variables (mapcar #'first bindings))
 663          (cvalues (mapcar #'convert (mapcar #'second bindings)))
 664          (*environment* (extend-local-env (remove-if #'special-variable-p variables)))
 665          (dynamic-bindings))
 666     `(call (function ,(mapcar (lambda (x)
 667                                 (if (special-variable-p x)
 668                                     (let ((v (gvarname x)))
 669                                       (push (cons x v) dynamic-bindings)
 670                                       v)
 671                                     (translate-variable x)))
 672                               variables)
 673                      ,(let ((body (convert-block body t t)))
 674                            `,(let-binding-wrapper dynamic-bindings body)))
 675            ,@cvalues)))
 676
 677
 678 ;;; Return the code to initialize BINDING, and push it extending the
 679 ;;; current lexical environment if the variable is not special.
 680 (defun let*-initialize-value (binding)
 681   (let ((var (first binding))
 682         (value (second binding)))
 683     (if (special-variable-p var)
 684         (convert `(setq ,var ,value))
 685         (let* ((v (gvarname var))
 686                (b (make-binding :name var :type 'variable :value v)))
 687           (prog1 `(var (,v ,(convert value)))
 688             (push-to-lexenv b *environment* 'variable))))))
 689
 690 ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It
 691 ;;; DOES NOT generate code to initialize the value of the symbols,
 692 ;;; unlike let-binding-wrapper.
 693 (defun let*-binding-wrapper (symbols body)
 694   (when (null symbols)
 695     (return-from let*-binding-wrapper body))
 696   (let ((store (mapcar (lambda (s) (cons s (gvarname s)))
 697                        (remove-if-not #'special-variable-p symbols))))
 698     `(progn
 699        (try
 700         ,@(mapcar (lambda (b)
 701                     (let ((s (convert `(quote ,(car b)))))
 702                       `(var (,(cdr b) (get ,s "value")))))
 703                   store)
 704         ,body)
 705        (finally
 706         ,@(mapcar (lambda (b)
 707                     (let ((s (convert `(quote ,(car b)))))
 708                       `(= (get ,s "value") ,(cdr b))))
 709                   store)))))
 710
 711 (define-compilation let* (bindings &rest body)
 712   (let ((bindings (mapcar #'ensure-list bindings))
 713         (*environment* (copy-lexenv *environment*)))
 714     (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
 715           (body `(progn
 716                    ,@(mapcar #'let*-initialize-value bindings)
 717                    ,(convert-block body t t))))
 718       `(selfcall ,(let*-binding-wrapper specials body)))))
 719
 720
 721 (define-compilation block (name &rest body)
 722   ;; We use Javascript exceptions to implement non local control
 723   ;; transfer. Exceptions has dynamic scoping, so we use a uniquely
 724   ;; generated object to identify the block. The instance of a empty
 725   ;; array is used to distinguish between nested dynamic Javascript
 726   ;; exceptions. See https://github.com/davazp/jscl/issues/64 for
 727   ;; futher details.
 728   (let* ((idvar (gvarname name))
 729          (b (make-binding :name name :type 'block :value idvar)))
 730     (when *multiple-value-p*
 731       (push 'multiple-value (binding-declarations b)))
 732     (let* ((*environment* (extend-lexenv (list b) *environment* 'block))
 733            (cbody (convert-block body t)))
 734       (if (member 'used (binding-declarations b))
 735           `(selfcall
 736             (try
 737              (var (,idvar #()))
 738              ,cbody)
 739             (catch (cf)
 740               (if (and (== (get cf "type") "block")
 741                        (== (get cf "id") ,idvar))
 742                   ,(if *multiple-value-p*
 743                        `(return (method-call |values| "apply" this (call |forcemv| (get cf "values"))))
 744                        `(return (get cf "values")))
 745                   (throw cf))))
 746           ;; TODO: is selfcall necessary here?
 747           `(selfcall ,cbody)))))
 748
 749 (define-compilation return-from (name &optional value)
 750   (let* ((b (lookup-in-lexenv name *environment* 'block))
 751          (multiple-value-p (member 'multiple-value (binding-declarations b))))
 752     (when (null b)
 753       (error "Return from unknown block `~S'." (symbol-name name)))
 754     (push 'used (binding-declarations b))
 755     ;; The binding value is the name of a variable, whose value is the
 756     ;; unique identifier of the block as exception. We can't use the
 757     ;; variable name itself, because it could not to be unique, so we
 758     ;; capture it in a closure.
 759     `(selfcall
 760       ,(when multiple-value-p `(var (|values| |mv|)))
 761       (throw
 762           (object
 763            "type" "block"
 764            "id" ,(binding-value b)
 765            "values" ,(convert value multiple-value-p)
 766            "message" ,(concat "Return from unknown block '" (symbol-name name) "'."))))))
 767
 768 (define-compilation catch (id &rest body)
 769   `(selfcall
 770     (var (|id| ,(convert id)))
 771     (try
 772      ,(convert-block body t))
 773     (catch (|cf|)
 774       (if (and (== (get |cf| "type") "catch")
 775                (== (get |cf| "id") |id|))
 776           ,(if *multiple-value-p*
 777                `(return (method-call |values| "apply" this (call |forcemv| (get |cf| "values"))))
 778                `(return (method-call |pv|     "apply" this (call |forcemv| (get |cf| "values")))))
 779           (throw |cf|)))))
 780
 781 (define-compilation throw (id value)
 782   `(selfcall
 783     (var (|values| |mv|))
 784     (throw (object
 785             |type| "catch"
 786             |id| ,(convert id)
 787             |values| ,(convert value t)
 788             |message| "Throw uncatched."))))
 789
 790 (defun go-tag-p (x)
 791   (or (integerp x) (symbolp x)))
 792
 793 (defun declare-tagbody-tags (tbidx body)
 794   (let* ((go-tag-counter 0)
 795          (bindings
 796           (mapcar (lambda (label)
 797                     (let ((tagidx (incf go-tag-counter)))
 798                       (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
 799                   (remove-if-not #'go-tag-p body))))
 800     (extend-lexenv bindings *environment* 'gotag)))
 801
 802 (define-compilation tagbody (&rest body)
 803   ;; Ignore the tagbody if it does not contain any go-tag. We do this
 804   ;; because 1) it is easy and 2) many built-in forms expand to a
 805   ;; implicit tagbody, so we save some space.
 806   (unless (some #'go-tag-p body)
 807     (return-from tagbody (convert `(progn ,@body nil))))
 808   ;; The translation assumes the first form in BODY is a label
 809   (unless (go-tag-p (car body))
 810     (push (gensym "START") body))
 811   ;; Tagbody compilation
 812   (let ((branch (gvarname 'branch))
 813         (tbidx (gvarname 'tbidx)))
 814     (let ((*environment* (declare-tagbody-tags tbidx body))
 815           initag)
 816       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
 817         (setq initag (second (binding-value b))))
 818       `(selfcall
 819         ;; TAGBODY branch to take
 820         (var (,branch ,initag))
 821         (var (,tbidx #()))
 822         (label tbloop
 823                (while true
 824                  (try
 825                   (switch ,branch
 826                           ,@(with-collect
 827                              (collect `(case ,initag))
 828                              (dolist (form (cdr body))
 829                                (if (go-tag-p form)
 830                                    (let ((b (lookup-in-lexenv form *environment* 'gotag)))
 831                                      (collect `(case ,(second (binding-value b)))))
 832                                    (collect (convert form)))))
 833                           default
 834                           (break tbloop)))
 835                  (catch (jump)
 836                    (if (and (== (get jump "type") "tagbody")
 837                             (== (get jump "id") ,tbidx))
 838                        (= ,branch (get jump "label"))
 839                        (throw jump)))))
 840         (return ,(convert nil))))))
 841
 842 (define-compilation go (label)
 843   (let ((b (lookup-in-lexenv label *environment* 'gotag))
 844         (n (cond
 845              ((symbolp label) (symbol-name label))
 846              ((integerp label) (integer-to-string label)))))
 847     (when (null b)
 848       (error "Unknown tag `~S'" label))
 849     `(selfcall
 850       (throw
 851           (object
 852            "type" "tagbody"
 853            "id" ,(first (binding-value b))
 854            "label" ,(second (binding-value b))
 855            "message" ,(concat "Attempt to GO to non-existing tag " n))))))
 856
 857 (define-compilation unwind-protect (form &rest clean-up)
 858   `(selfcall
 859     (var (|ret| ,(convert nil)))
 860     (try
 861      (= |ret| ,(convert form)))
 862     (finally
 863      ,(convert-block clean-up))
 864     (return |ret|)))
 865
 866 (define-compilation multiple-value-call (func-form &rest forms)
 867   `(selfcall
 868     (var (func ,(convert func-form)))
 869     (var (args ,(vector (if *multiple-value-p* '|values| '|pv|) 0)))
 870     (return
 871       (selfcall
 872        (var (|values| |mv|))
 873        (var vs)
 874        (progn
 875          ,@(with-collect
 876             (dolist (form forms)
 877               (collect `(= vs ,(convert form t)))
 878               (collect `(if (and (=== (typeof vs) "object")
 879                                  (in "multiple-value" vs))
 880                             (= args (method-call args "concat" vs))
 881                             (method-call args "push" vs))))))
 882        (= (property args 1) (- (property args "length") 2))
 883        (return (method-call func "apply" |window| args))))))
 884
 885 (define-compilation multiple-value-prog1 (first-form &rest forms)
 886   `(selfcall
 887     (var (args ,(convert first-form *multiple-value-p*)))
 888     ;; TODO: Interleave is temporal
 889     (progn ,@(mapcar #'convert forms))
 890     (return args)))
 891
 892 (define-transformation backquote (form)
 893   (bq-completely-process form))
 894
 895
 896 ;;; Primitives
 897
 898 (defvar *builtins* nil)
 899
 900 (defmacro define-raw-builtin (name args &body body)
 901   ;; Creates a new primitive function `name' with parameters args and
 902   ;; @body. The body can access to the local environment through the
 903   ;; variable *ENVIRONMENT*.
 904   `(push (list ',name (lambda ,args (block ,name ,@body)))
 905          *builtins*))
 906
 907 (defmacro define-builtin (name args &body body)
 908   `(define-raw-builtin ,name ,args
 909      (let ,(mapcar (lambda (arg) `(,arg (convert ,arg))) args)
 910        ,@body)))
 911
 912 ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
 913 ;;; a variable which holds a list of forms. It will compile them and
 914 ;;; store the result in some Javascript variables. BODY is evaluated
 915 ;;; with ARGS bound to the list of these variables to generate the
 916 ;;; code which performs the transformation on these variables.
 917 (defun variable-arity-call (args function)
 918   (unless (consp args)
 919     (error "ARGS must be a non-empty list"))
 920   (let ((counter 0)
 921         (fargs '())
 922         (prelude '()))
 923     (dolist (x args)
 924       (if (or (floatp x) (numberp x))
 925           (push x fargs)
 926           (let ((v (make-symbol (concat "x" (integer-to-string (incf counter))))))
 927             (push v fargs)
 928             (push `(var (,v ,(convert x)))
 929                   prelude)
 930             (push `(if (!= (typeof ,v) "number")
 931                        (throw "Not a number!"))
 932                   prelude))))
 933     `(selfcall
 934       (progn ,@(reverse prelude))
 935       ,(funcall function (reverse fargs)))))
 936
 937
 938 (defmacro variable-arity (args &body body)
 939   (unless (symbolp args)
 940     (error "`~S' is not a symbol." args))
 941   `(variable-arity-call ,args (lambda (,args) `(return  ,,@body))))
 942
 943 (define-raw-builtin + (&rest numbers)
 944   (if (null numbers)
 945       0
 946       (variable-arity numbers
 947         `(+ ,@numbers))))
 948
 949 (define-raw-builtin - (x &rest others)
 950   (let ((args (cons x others)))
 951     (variable-arity args `(- ,@args))))
 952
 953 (define-raw-builtin * (&rest numbers)
 954   (if (null numbers)
 955       1
 956       (variable-arity numbers `(* ,@numbers))))
 957
 958 (define-raw-builtin / (x &rest others)
 959   (let ((args (cons x others)))
 960     (variable-arity args
 961       (if (null others)
 962           `(/ 1 ,(car args))
 963           (reduce (lambda (x y) `(/ ,x ,y))
 964                   args)))))
 965
 966 (define-builtin mod (x y)
 967   `(% ,x ,y))
 968
 969
 970 (defun comparison-conjuntion (vars op)
 971   (cond
 972     ((null (cdr vars))
 973      'true)
 974     ((null (cddr vars))
 975      `(,op ,(car vars) ,(cadr vars)))
 976     (t
 977      `(and (,op ,(car vars) ,(cadr vars))
 978            ,(comparison-conjuntion (cdr vars) op)))))
 979
 980 (defmacro define-builtin-comparison (op sym)
 981   `(define-raw-builtin ,op (x &rest args)
 982      (let ((args (cons x args)))
 983        (variable-arity args
 984          `(bool ,(comparison-conjuntion args ',sym))))))
 985
 986 (define-builtin-comparison > >)
 987 (define-builtin-comparison < <)
 988 (define-builtin-comparison >= >=)
 989 (define-builtin-comparison <= <=)
 990 (define-builtin-comparison = ==)
 991 (define-builtin-comparison /= !=)
 992
 993 (define-builtin numberp (x)
 994   `(bool (== (typeof ,x) "number")))
 995
 996 (define-builtin floor (x)
 997   `(method-call |Math| "floor" ,x))
 998
 999 (define-builtin expt (x y)
1000   `(method-call |Math| "pow" ,x ,y))
1001
1002 (define-builtin float-to-string (x)
1003   `(call |make_lisp_string| (method-call ,x |toString|)))
1004
1005 (define-builtin cons (x y)
1006   `(object "car" ,x "cdr" ,y))
1007
1008 (define-builtin consp (x)
1009   `(selfcall
1010     (var (tmp ,x))
1011     (return (bool (and (== (typeof tmp) "object")
1012                        (in "car" tmp))))))
1013
1014 (define-builtin car (x)
1015   `(selfcall
1016     (var (tmp ,x))
1017     (return (if (=== tmp ,(convert nil))
1018                 ,(convert nil)
1019                 (get tmp "car")))))
1020
1021 (define-builtin cdr (x)
1022   `(selfcall
1023     (var (tmp ,x))
1024     (return (if (=== tmp ,(convert nil))
1025                 ,(convert nil)
1026                 (get tmp "cdr")))))
1027
1028 (define-builtin rplaca (x new)
1029   `(= (get ,x "car") ,new))
1030
1031 (define-builtin rplacd (x new)
1032   `(= (get ,x "cdr") ,new))
1033
1034 (define-builtin symbolp (x)
1035   `(bool (instanceof ,x |Symbol|)))
1036
1037 (define-builtin make-symbol (name)
1038   `(new (call |Symbol| ,name)))
1039
1040 (define-builtin symbol-name (x)
1041   `(get ,x "name"))
1042
1043 (define-builtin set (symbol value)
1044   `(= (get ,symbol "value") ,value))
1045
1046 (define-builtin fset (symbol value)
1047   `(= (get ,symbol "fvalue") ,value))
1048
1049 (define-builtin boundp (x)
1050   `(bool (!== (get ,x "value") undefined)))
1051
1052 (define-builtin fboundp (x)
1053   `(bool (!== (get ,x "fvalue") undefined)))
1054
1055 (define-builtin symbol-value (x)
1056   `(selfcall
1057     (var (symbol ,x)
1058          (value (get symbol "value")))
1059     (if (=== value undefined)
1060         (throw (+ "Variable `" (call |xstring| (get symbol "name")) "' is unbound.")))
1061     (return value)))
1062
1063 (define-builtin symbol-function (x)
1064   `(selfcall
1065     (var (symbol ,x)
1066          (func (get symbol "fvalue")))
1067     (if (=== func undefined)
1068         (throw (+ "Function `" (call |xstring| (get symbol "name")) "' is undefined.")))
1069     (return func)))
1070
1071 (define-builtin symbol-plist (x)
1072   `(or (get ,x "plist") ,(convert nil)))
1073
1074 (define-builtin lambda-code (x)
1075   `(call |make_lisp_string| (method-call ,x "toString")))
1076
1077 (define-builtin eq (x y)
1078   `(bool (=== ,x ,y)))
1079
1080 (define-builtin char-code (x)
1081   `(call |char_to_codepoint| ,x))
1082
1083 (define-builtin code-char (x)
1084   `(call |char_from_codepoint| ,x))
1085
1086 (define-builtin characterp (x)
1087   `(selfcall
1088     (var (x ,x))
1089     (return (bool
1090              (and (== (typeof x) "string")
1091                   (or (== (get x "length") 1)
1092                       (== (get x "length") 2)))))))
1093
1094 (define-builtin char-upcase (x)
1095   `(call |safe_char_upcase| ,x))
1096
1097 (define-builtin char-downcase (x)
1098   `(call |safe_char_downcase| ,x))
1099
1100 (define-builtin stringp (x)
1101   `(selfcall
1102     (var (x ,x))
1103     (return (bool
1104              (and (and (===(typeof x) "object")
1105                        (in "length" x))
1106                   (== (get x "stringp") 1))))))
1107
1108 (define-raw-builtin funcall (func &rest args)
1109   `(selfcall
1110     (var (f ,(convert func)))
1111     (return (call (if (=== (typeof f) "function")
1112                       f
1113                       (get f "fvalue"))
1114                   ,@(list* (if *multiple-value-p* '|values| '|pv|)
1115                            (length args)
1116                            (mapcar #'convert args))))))
1117
1118 (define-raw-builtin apply (func &rest args)
1119   (if (null args)
1120       (convert func)
1121       (let ((args (butlast args))
1122             (last (car (last args))))
1123         `(selfcall
1124            (var (f ,(convert func)))
1125            (var (args ,(list-to-vector
1126                         (list* (if *multiple-value-p* '|values| '|pv|)
1127                                (length args)
1128                                (mapcar #'convert args)))))
1129            (var (tail ,(convert last)))
1130            (while (!= tail ,(convert nil))
1131              (method-call args "push" (get tail "car"))
1132              (post++ (property args 1))
1133              (= tail (get tail "cdr")))
1134            (return (method-call (if (=== (typeof f) "function")
1135                                     f
1136                                     (get f "fvalue"))
1137                                 "apply"
1138                                 this
1139                                 args))))))
1140
1141 (define-builtin js-eval (string)
1142   (if *multiple-value-p*
1143       `(selfcall
1144         (var (v (call |globalEval| (call |xstring| ,string))))
1145         (return (method-call |values| "apply" this (call |forcemv| v))))
1146       `(call |globalEval| (call |xstring| ,string))))
1147
1148 (define-builtin %throw (string)
1149   `(selfcall (throw ,string)))
1150
1151 (define-builtin functionp (x)
1152   `(bool (=== (typeof ,x) "function")))
1153
1154 (define-builtin %write-string (x)
1155   `(method-call |lisp| "write" ,x))
1156
1157 (define-builtin /debug (x)
1158   `(method-call |console| "log" (call |xstring| ,x)))
1159
1160
1161 ;;; Storage vectors. They are used to implement arrays and (in the
1162 ;;; future) structures.
1163
1164 (define-builtin storage-vector-p (x)
1165   `(selfcall
1166     (var (x ,x))
1167     (return (bool (and (=== (typeof x) "object") (in "length" x))))))
1168
1169 (define-builtin make-storage-vector (n)
1170   `(selfcall
1171     (var (r #()))
1172     (= (get r "length") ,n)
1173     (return r)))
1174
1175 (define-builtin storage-vector-size (x)
1176   `(get ,x "length"))
1177
1178 (define-builtin resize-storage-vector (vector new-size)
1179   `(= (get ,vector "length") ,new-size))
1180
1181 (define-builtin storage-vector-ref (vector n)
1182   `(selfcall
1183     (var (x (property ,vector ,n)))
1184     (if (=== x undefined) (throw "Out of range."))
1185     (return x)))
1186
1187 (define-builtin storage-vector-set (vector n value)
1188   `(selfcall
1189     (var (x ,vector))
1190     (var (i ,n))
1191     (if (or (< i 0) (>= i (get x "length")))
1192         (throw "Out of range."))
1193     (return (= (property x i) ,value))))
1194
1195 (define-builtin concatenate-storage-vector (sv1 sv2)
1196   `(selfcall
1197      (var (sv1 ,sv1))
1198      (var (r (method-call sv1 "concat" ,sv2)))
1199      (= (get r "type") (get sv1 "type"))
1200      (= (get r "stringp") (get sv1 "stringp"))
1201      (return r)))
1202
1203 (define-builtin get-internal-real-time ()
1204   `(method-call (new (call |Date|)) "getTime"))
1205
1206 (define-builtin values-array (array)
1207   (if *multiple-value-p*
1208       `(method-call |values| "apply" this ,array)
1209       `(method-call |pv| "apply" this ,array)))
1210
1211 (define-raw-builtin values (&rest args)
1212   (if *multiple-value-p*
1213       `(call |values| ,@(mapcar #'convert args))
1214       `(call |pv| ,@(mapcar #'convert args))))
1215
1216 ;;; Javascript FFI
1217
1218 (define-builtin new ()
1219   '(object))
1220
1221 (define-raw-builtin oget* (object key &rest keys)
1222   `(selfcall
1223     (progn
1224       (var (tmp (property ,(convert object) (call |xstring| ,(convert key)))))
1225       ,@(mapcar (lambda (key)
1226                   `(progn
1227                      (if (=== tmp undefined) (return ,(convert nil)))
1228                      (= tmp (property tmp (call |xstring| ,(convert key))))))
1229                 keys))
1230     (return (if (=== tmp undefined) ,(convert nil) tmp))))
1231
1232 (define-raw-builtin oset* (value object key &rest keys)
1233   (let ((keys (cons key keys)))
1234     `(selfcall
1235       (progn
1236         (var (obj ,(convert object)))
1237         ,@(mapcar (lambda (key)
1238                     `(progn
1239                        (= obj (property obj (call |xstring| ,(convert key))))
1240                        (if (=== object undefined)
1241                            (throw "Impossible to set object property."))))
1242                   (butlast keys))
1243         (var (tmp
1244               (= (property obj (call |xstring| ,(convert (car (last keys)))))
1245                  ,(convert value))))
1246         (return (if (=== tmp undefined)
1247                     ,(convert nil)
1248                     tmp))))))
1249
1250 (define-raw-builtin oget (object key &rest keys)
1251   `(call |js_to_lisp| ,(convert `(oget* ,object ,key ,@keys))))
1252
1253 (define-raw-builtin oset (value object key &rest keys)
1254   (convert `(oset* (lisp-to-js ,value) ,object ,key ,@keys)))
1255
1256 (define-builtin objectp (x)
1257   `(bool (=== (typeof ,x) "object")))
1258
1259 (define-builtin lisp-to-js (x) `(call |lisp_to_js| ,x))
1260 (define-builtin js-to-lisp (x) `(call |js_to_lisp| ,x))
1261
1262
1263 (define-builtin in (key object)
1264   `(bool (in (call |xstring| ,key) ,object)))
1265
1266 (define-builtin map-for-in (function object)
1267   `(selfcall
1268     (var (f ,function)
1269          (g (if (=== (typeof f) "function") f (get f "fvalue")))
1270          (o ,object))
1271     (for-in (key o)
1272             (call g ,(if *multiple-value-p* '|values| '|pv|) 1 (get o "key")))
1273     (return ,(convert nil))))
1274
1275 (define-compilation %js-vref (var)
1276   `(call |js_to_lisp| ,(make-symbol var)))
1277
1278 (define-compilation %js-vset (var val)
1279   `(= ,(make-symbol var) (call |lisp_to_js| ,(convert val))))
1280
1281 (define-setf-expander %js-vref (var)
1282   (let ((new-value (gensym)))
1283     (unless (stringp var)
1284       (error "`~S' is not a string." var))
1285     (values nil
1286             (list var)
1287             (list new-value)
1288             `(%js-vset ,var ,new-value)
1289             `(%js-vref ,var))))
1290
1291
1292 #-jscl
1293 (defvar *macroexpander-cache*
1294   (make-hash-table :test #'eq))
1295
1296 (defun !macro-function (symbol)
1297   (unless (symbolp symbol)
1298     (error "`~S' is not a symbol." symbol))
1299   (let ((b (lookup-in-lexenv symbol *environment* 'function)))
1300     (if (and b (eq (binding-type b) 'macro))
1301         (let ((expander (binding-value b)))
1302           (cond
1303             #-jscl
1304             ((gethash b *macroexpander-cache*)
1305              (setq expander (gethash b *macroexpander-cache*)))
1306             ((listp expander)
1307              (let ((compiled (eval expander)))
1308                ;; The list representation are useful while
1309                ;; bootstrapping, as we can dump the definition of the
1310                ;; macros easily, but they are slow because we have to
1311                ;; evaluate them and compile them now and again. So, let
1312                ;; us replace the list representation version of the
1313                ;; function with the compiled one.
1314                ;;
1315                #+jscl (setf (binding-value b) compiled)
1316                #-jscl (setf (gethash b *macroexpander-cache*) compiled)
1317                (setq expander compiled))))
1318           expander)
1319         nil)))
1320
1321 (defun !macroexpand-1 (form)
1322   (cond
1323     ((symbolp form)
1324      (let ((b (lookup-in-lexenv form *environment* 'variable)))
1325        (if (and b (eq (binding-type b) 'macro))
1326            (values (binding-value b) t)
1327            (values form nil))))
1328     ((and (consp form) (symbolp (car form)))
1329      (let ((macrofun (!macro-function (car form))))
1330        (if macrofun
1331            (values (funcall macrofun (cdr form)) t)
1332            (values form nil))))
1333     (t
1334      (values form nil))))
1335
1336 (defun compile-funcall (function args)
1337   (let* ((arglist (list* (if *multiple-value-p* '|values| '|pv|)
1338                          (length args)
1339                          (mapcar #'convert args))))
1340     (unless (or (symbolp function)
1341                 (and (consp function)
1342                      (member (car function) '(lambda oget))))
1343       (error "Bad function designator `~S'" function))
1344     (cond
1345       ((translate-function function)
1346        `(call ,(translate-function function) ,@arglist))
1347       ((and (symbolp function)
1348             #+jscl (eq (symbol-package function) (find-package "COMMON-LISP"))
1349             #-jscl t)
1350        `(method-call ,(convert `',function) "fvalue" ,@arglist))
1351       #+jscl((symbolp function)
1352              `(call ,(convert `#',function) ,@arglist))
1353       ((and (consp function) (eq (car function) 'lambda))
1354        `(call ,(convert `#',function) ,@arglist))
1355       ((and (consp function) (eq (car function) 'oget))
1356        `(call ,(convert function) ,@arglist))
1357       (t
1358        (error "Bad function descriptor")))))
1359
1360 (defun convert-block (sexps &optional return-last-p decls-allowed-p)
1361   (multiple-value-bind (sexps decls)
1362       (parse-body sexps :declarations decls-allowed-p)
1363     (declare (ignore decls))
1364     (if return-last-p
1365         `(progn
1366            ,@(mapcar #'convert (butlast sexps))
1367            (return ,(convert (car (last sexps)) *multiple-value-p*)))
1368         `(progn ,@(mapcar #'convert sexps)))))
1369
1370 (defun convert* (sexp &optional multiple-value-p)
1371   (multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp)
1372     (when expandedp
1373       (return-from convert* (convert sexp multiple-value-p)))
1374     ;; The expression has been macroexpanded. Now compile it!
1375     (let ((*multiple-value-p* multiple-value-p))
1376       (cond
1377         ((symbolp sexp)
1378          (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
1379            (cond
1380              ((and b (not (member 'special (binding-declarations b))))
1381               (binding-value b))
1382              ((or (keywordp sexp)
1383                   (and b (member 'constant (binding-declarations b))))
1384               `(get ,(convert `',sexp) "value"))
1385              (t
1386               (convert `(symbol-value ',sexp))))))
1387         ((or (integerp sexp) (floatp sexp) (characterp sexp) (stringp sexp) (arrayp sexp))
1388          (literal sexp))
1389         ((listp sexp)
1390          (let ((name (car sexp))
1391                (args (cdr sexp)))
1392            (cond
1393              ;; Special forms
1394              ((assoc name *compilations*)
1395               (let ((comp (second (assoc name *compilations*))))
1396                 (apply comp args)))
1397              ;; Built-in functions
1398              ((and (assoc name *builtins*)
1399                    (not (claimp name 'function 'notinline)))
1400               (let ((comp (second (assoc name *builtins*))))
1401                 (apply comp args)))
1402              (t
1403               (compile-funcall name args)))))
1404         (t
1405          (error "How should I compile `~S'?" sexp))))))
1406
1407 (defun convert (sexp &optional multiple-value-p)
1408   (convert* sexp multiple-value-p))
1409
1410
1411 (defvar *compile-print-toplevels* nil)
1412
1413 (defun truncate-string (string &optional (width 60))
1414   (let ((n (or (position #\newline string)
1415                (min width (length string)))))
1416     (subseq string 0 n)))
1417
1418 (defun convert-toplevel (sexp &optional multiple-value-p)
1419   (let ((*toplevel-compilations* nil))
1420     (cond
1421       ;; Non-empty toplevel progn
1422       ((and (consp sexp)
1423             (eq (car sexp) 'progn)
1424             (cdr sexp))
1425        `(progn
1426           ,@(mapcar (lambda (s) (convert-toplevel s t))
1427                     (cdr sexp))))
1428       (t
1429        (when *compile-print-toplevels*
1430          (let ((form-string (prin1-to-string sexp)))
1431            (format t "Compiling ~a..." (truncate-string form-string))))
1432        (let ((code (convert sexp multiple-value-p)))
1433          `(progn
1434             ,@(get-toplevel-compilations)
1435             ,code))))))
1436
1437 (defun compile-toplevel (sexp &optional multiple-value-p)
1438   (with-output-to-string (*standard-output*)
1439     (js (convert-toplevel sexp multiple-value-p))))