src/compiler.lisp

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