src/compiler.lisp

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