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