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