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