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