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