src/compiler.lisp

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