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