src/compiler.lisp

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