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