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 ;;; Two seperate functions are needed for escaping strings:
 493 ;;;  One for producing JavaScript string literals (which are singly or
 494 ;;;   doubly quoted)
 495 ;;;  And one for producing Lisp strings (which are only doubly quoted)
 496 ;;;
 497 ;;; The same function would suffice for both, but for javascript string
 498 ;;; literals it is neater to use either depending on the context, e.g:
 499 ;;;  foo's => "foo's"
 500 ;;;  "foo" => '"foo"'
 501 ;;; which avoids having to escape quotes where possible
 502 (defun js-escape-string (string)
 503   (let ((index 0)
 504         (size (length string))
 505         (seen-single-quote nil)
 506         (seen-double-quote nil))
 507     (flet ((%js-escape-string (string escape-single-quote-p)
 508              (let ((output "")
 509                    (index 0))
 510                (while (< index size)
 511                  (let ((ch (char string index)))
 512                    (when (char= ch #\\)
 513                      (setq output (concat output "\\")))
 514                    (when (and escape-single-quote-p (char= ch #\'))
 515                      (setq output (concat output "\\")))
 516                    (when (char= ch #\newline)
 517                      (setq output (concat output "\\"))
 518                      (setq ch #\n))
 519                    (setq output (concat output (string ch))))
 520                  (incf index))
 521                output)))
 522       ;; First, scan the string for single/double quotes
 523       (while (< index size)
 524         (let ((ch (char string index)))
 525           (when (char= ch #\')
 526             (setq seen-single-quote t))
 527           (when (char= ch #\")
 528             (setq seen-double-quote t)))
 529         (incf index))
 530       ;; Then pick the appropriate way to escape the quotes
 531       (cond
 532         ((not seen-single-quote)
 533          (concat "'"   (%js-escape-string string nil) "'"))
 534         ((not seen-double-quote)
 535          (concat "\""  (%js-escape-string string nil) "\""))
 536         (t (concat "'" (%js-escape-string string t)   "'"))))))
 537
 538 (defun lisp-escape-string (string)
 539   (let ((output "")
 540         (index 0)
 541         (size (length string)))
 542     (while (< index size)
 543       (let ((ch (char string index)))
 544         (when (or (char= ch #\") (char= ch #\\))
 545           (setq output (concat output "\\")))
 546         (when (or (char= ch #\newline))
 547           (setq output (concat output "\\"))
 548           (setq ch #\n))
 549         (setq output (concat output (string ch))))
 550       (incf index))
 551     (concat "\"" output "\"")))
 552
 553 ;;; BOOTSTRAP MAGIC: We record the macro definitions as lists during
 554 ;;; the bootstrap. Once everything is compiled, we want to dump the
 555 ;;; whole global environment to the output file to reproduce it in the
 556 ;;; run-time. However, the environment must contain expander functions
 557 ;;; rather than lists. We do not know how to dump function objects
 558 ;;; itself, so we mark the list definitions with this object and the
 559 ;;; compiler will be called when this object has to be dumped.
 560 ;;; Backquote/unquote does a similar magic, but this use is exclusive.
 561 ;;;
 562 ;;; Indeed, perhaps to compile the object other macros need to be
 563 ;;; evaluated. For this reason we define a valid macro-function for
 564 ;;; this symbol.
 565 (defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE"))
 566 #-jscl
 567 (setf (macro-function *magic-unquote-marker*)
 568       (lambda (form &optional environment)
 569         (declare (ignore environment))
 570         (second form)))
 571
 572 (defvar *literal-table* nil)
 573 (defvar *literal-counter* 0)
 574
 575 (defun genlit ()
 576   (code "l" (incf *literal-counter*)))
 577
 578 (defun dump-symbol (symbol)
 579   #-jscl
 580   (let ((package (symbol-package symbol)))
 581     (if (eq package (find-package "KEYWORD"))
 582         (code "(new Symbol(" (dump-string (symbol-name symbol)) ", " (dump-string (package-name package)) "))")
 583         (code "(new Symbol(" (dump-string (symbol-name symbol)) "))")))
 584   #+jscl
 585   (let ((package (symbol-package symbol)))
 586     (if (null package)
 587         (code "(new Symbol(" (dump-string (symbol-name symbol)) "))")
 588         (ls-compile `(intern ,(symbol-name symbol) ,(package-name package))))))
 589
 590 (defun dump-cons (cons)
 591   (let ((head (butlast cons))
 592         (tail (last cons)))
 593     (code "QIList("
 594           (join-trailing (mapcar (lambda (x) (literal x t)) head) ",")
 595           (literal (car tail) t)
 596           ","
 597           (literal (cdr tail) t)
 598           ")")))
 599
 600 (defun dump-array (array)
 601   (let ((elements (vector-to-list array)))
 602     (concat "[" (join (mapcar #'literal elements) ", ") "]")))
 603
 604 (defun dump-string (string)
 605   (code "make_lisp_string(" (js-escape-string string) ")"))
 606
 607 (defun literal (sexp &optional recursive)
 608   (cond
 609     ((integerp sexp) (integer-to-string sexp))
 610     ((floatp sexp) (float-to-string sexp))
 611     ((characterp sexp) (js-escape-string (string sexp)))
 612     (t
 613      (or (cdr (assoc sexp *literal-table* :test #'eql))
 614          (let ((dumped (typecase sexp
 615                          (symbol (dump-symbol sexp))
 616                          (string (dump-string sexp))
 617                          (cons
 618                           ;; BOOTSTRAP MAGIC: See the root file
 619                           ;; jscl.lisp and the function
 620                           ;; `dump-global-environment' for futher
 621                           ;; information.
 622                           (if (eq (car sexp) *magic-unquote-marker*)
 623                               (ls-compile (second sexp))
 624                               (dump-cons sexp)))
 625                          (array (dump-array sexp)))))
 626            (if (and recursive (not (symbolp sexp)))
 627                dumped
 628                (let ((jsvar (genlit)))
 629                  (push (cons sexp jsvar) *literal-table*)
 630                  (toplevel-compilation (code "var " jsvar " = " dumped))
 631                  (when (keywordp sexp)
 632                    (toplevel-compilation (code jsvar ".value = " jsvar)))
 633                  jsvar)))))))
 634
 635
 636 (define-compilation quote (sexp)
 637   (literal sexp))
 638
 639 (define-compilation %while (pred &rest body)
 640   (js!selfcall
 641     "while(" (ls-compile pred) " !== " (ls-compile nil) "){" *newline*
 642     (indent (ls-compile-block body))
 643     "}"
 644     "return " (ls-compile nil) ";" *newline*))
 645
 646 (define-compilation function (x)
 647   (cond
 648     ((and (listp x) (eq (car x) 'lambda))
 649      (compile-lambda (cadr x) (cddr x)))
 650     ((and (listp x) (eq (car x) 'named-lambda))
 651      ;; TODO: destructuring-bind now! Do error checking manually is
 652      ;; very annoying.
 653      (let ((name (cadr x))
 654            (ll (caddr x))
 655            (body (cdddr x)))
 656        (compile-lambda ll body
 657                        :name (symbol-name name)
 658                        :block name)))
 659     ((symbolp x)
 660      (let ((b (lookup-in-lexenv x *environment* 'function)))
 661        (if b
 662            (binding-value b)
 663            (ls-compile `(symbol-function ',x)))))))
 664
 665
 666 (defun make-function-binding (fname)
 667   (make-binding :name fname :type 'function :value (gvarname fname)))
 668
 669 (defun compile-function-definition (list)
 670   (compile-lambda (car list) (cdr list)))
 671
 672 (defun translate-function (name)
 673   (let ((b (lookup-in-lexenv name *environment* 'function)))
 674     (and b (binding-value b))))
 675
 676 (define-compilation flet (definitions &rest body)
 677   (let* ((fnames (mapcar #'car definitions))
 678          (cfuncs (mapcar (lambda (def)
 679                            (compile-lambda (cadr def)
 680                                            `((block ,(car def)
 681                                                ,@(cddr def)))))
 682                          definitions))
 683          (*environment*
 684           (extend-lexenv (mapcar #'make-function-binding fnames)
 685                          *environment*
 686                          'function)))
 687     (code "(function("
 688           (join (mapcar #'translate-function fnames) ",")
 689           "){" *newline*
 690           (let ((body (ls-compile-block body t)))
 691             (indent body))
 692           "})(" (join cfuncs ",") ")")))
 693
 694 (define-compilation labels (definitions &rest body)
 695   (let* ((fnames (mapcar #'car definitions))
 696          (*environment*
 697           (extend-lexenv (mapcar #'make-function-binding fnames)
 698                          *environment*
 699                          'function)))
 700     (js!selfcall
 701       (mapconcat (lambda (func)
 702                    (code "var " (translate-function (car func))
 703                          " = " (compile-lambda (cadr func)
 704                                                `((block ,(car func) ,@(cddr func))))
 705                          ";" *newline*))
 706                  definitions)
 707       (ls-compile-block body t))))
 708
 709
 710 (defvar *compiling-file* nil)
 711 (define-compilation eval-when-compile (&rest body)
 712   (if *compiling-file*
 713       (progn
 714         (eval (cons 'progn body))
 715         nil)
 716       (ls-compile `(progn ,@body))))
 717
 718 (defmacro define-transformation (name args form)
 719   `(define-compilation ,name ,args
 720      (ls-compile ,form)))
 721
 722 (define-compilation progn (&rest body)
 723   (if (null (cdr body))
 724       (ls-compile (car body) *multiple-value-p*)
 725       (code "("
 726             (join
 727              (remove-if #'null-or-empty-p
 728                         (append
 729                          (mapcar #'ls-compile (butlast body))
 730                          (list (ls-compile (car (last body)) t))))
 731                   ",")
 732             ")")))
 733
 734 (define-compilation macrolet (definitions &rest body)
 735   (let ((*environment* (copy-lexenv *environment*)))
 736     (dolist (def definitions)
 737       (destructuring-bind (name lambda-list &body body) def
 738         (let ((binding (make-binding :name name :type 'macro :value
 739                                      (let ((g!form (gensym)))
 740                                        `(lambda (,g!form)
 741                                           (destructuring-bind ,lambda-list ,g!form
 742                                             ,@body))))))
 743           (push-to-lexenv binding  *environment* 'function))))
 744     (ls-compile `(progn ,@body) *multiple-value-p*)))
 745
 746
 747 (defun special-variable-p (x)
 748   (and (claimp x 'variable 'special) t))
 749
 750 ;;; Wrap CODE to restore the symbol values of the dynamic
 751 ;;; bindings. BINDINGS is a list of pairs of the form
 752 ;;; (SYMBOL . PLACE),  where PLACE is a Javascript variable
 753 ;;; name to initialize the symbol value and where to stored
 754 ;;; the old value.
 755 (defun let-binding-wrapper (bindings body)
 756   (when (null bindings)
 757     (return-from let-binding-wrapper body))
 758   (code
 759    "try {" *newline*
 760    (indent "var tmp;" *newline*
 761            (mapconcat
 762             (lambda (b)
 763               (let ((s (ls-compile `(quote ,(car b)))))
 764                 (code "tmp = " s ".value;" *newline*
 765                       s ".value = " (cdr b) ";" *newline*
 766                       (cdr b) " = tmp;" *newline*)))
 767             bindings)
 768            body *newline*)
 769    "}" *newline*
 770    "finally {"  *newline*
 771    (indent
 772     (mapconcat (lambda (b)
 773                  (let ((s (ls-compile `(quote ,(car b)))))
 774                    (code s ".value" " = " (cdr b) ";" *newline*)))
 775                bindings))
 776    "}" *newline*))
 777
 778 (define-compilation let (bindings &rest body)
 779   (let* ((bindings (mapcar #'ensure-list bindings))
 780          (variables (mapcar #'first bindings))
 781          (cvalues (mapcar #'ls-compile (mapcar #'second bindings)))
 782          (*environment* (extend-local-env (remove-if #'special-variable-p variables)))
 783          (dynamic-bindings))
 784     (code "(function("
 785           (join (mapcar (lambda (x)
 786                           (if (special-variable-p x)
 787                               (let ((v (gvarname x)))
 788                                 (push (cons x v) dynamic-bindings)
 789                                 v)
 790                               (translate-variable x)))
 791                         variables)
 792                 ",")
 793           "){" *newline*
 794           (let ((body (ls-compile-block body t t)))
 795             (indent (let-binding-wrapper dynamic-bindings body)))
 796           "})(" (join cvalues ",") ")")))
 797
 798
 799 ;;; Return the code to initialize BINDING, and push it extending the
 800 ;;; current lexical environment if the variable is not special.
 801 (defun let*-initialize-value (binding)
 802   (let ((var (first binding))
 803         (value (second binding)))
 804     (if (special-variable-p var)
 805         (code (ls-compile `(setq ,var ,value)) ";" *newline*)
 806         (let* ((v (gvarname var))
 807                (b (make-binding :name var :type 'variable :value v)))
 808           (prog1 (code "var " v " = " (ls-compile value) ";" *newline*)
 809             (push-to-lexenv b *environment* 'variable))))))
 810
 811 ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It
 812 ;;; DOES NOT generate code to initialize the value of the symbols,
 813 ;;; unlike let-binding-wrapper.
 814 (defun let*-binding-wrapper (symbols body)
 815   (when (null symbols)
 816     (return-from let*-binding-wrapper body))
 817   (let ((store (mapcar (lambda (s) (cons s (gvarname s)))
 818                        (remove-if-not #'special-variable-p symbols))))
 819     (code
 820      "try {" *newline*
 821      (indent
 822       (mapconcat (lambda (b)
 823                    (let ((s (ls-compile `(quote ,(car b)))))
 824                      (code "var " (cdr b) " = " s ".value;" *newline*)))
 825                  store)
 826       body)
 827      "}" *newline*
 828      "finally {" *newline*
 829      (indent
 830       (mapconcat (lambda (b)
 831                    (let ((s (ls-compile `(quote ,(car b)))))
 832                      (code s ".value" " = " (cdr b) ";" *newline*)))
 833                  store))
 834      "}" *newline*)))
 835
 836 (define-compilation let* (bindings &rest body)
 837   (let ((bindings (mapcar #'ensure-list bindings))
 838         (*environment* (copy-lexenv *environment*)))
 839     (js!selfcall
 840       (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
 841             (body (concat (mapconcat #'let*-initialize-value bindings)
 842                           (ls-compile-block body t t))))
 843         (let*-binding-wrapper specials body)))))
 844
 845
 846 (define-compilation block (name &rest body)
 847   ;; We use Javascript exceptions to implement non local control
 848   ;; transfer. Exceptions has dynamic scoping, so we use a uniquely
 849   ;; generated object to identify the block. The instance of a empty
 850   ;; array is used to distinguish between nested dynamic Javascript
 851   ;; exceptions. See https://github.com/davazp/jscl/issues/64 for
 852   ;; futher details.
 853   (let* ((idvar (gvarname name))
 854          (b (make-binding :name name :type 'block :value idvar)))
 855     (when *multiple-value-p*
 856       (push 'multiple-value (binding-declarations b)))
 857     (let* ((*environment* (extend-lexenv (list b) *environment* 'block))
 858            (cbody (ls-compile-block body t)))
 859       (if (member 'used (binding-declarations b))
 860           (js!selfcall
 861             "try {" *newline*
 862             "var " idvar " = [];" *newline*
 863             (indent cbody)
 864             "}" *newline*
 865             "catch (cf){" *newline*
 866             "    if (cf.type == 'block' && cf.id == " idvar ")" *newline*
 867             (if *multiple-value-p*
 868                 "        return values.apply(this, forcemv(cf.values));"
 869                 "        return cf.values;")
 870             *newline*
 871             "    else" *newline*
 872             "        throw cf;" *newline*
 873             "}" *newline*)
 874           (js!selfcall cbody)))))
 875
 876 (define-compilation return-from (name &optional value)
 877   (let* ((b (lookup-in-lexenv name *environment* 'block))
 878          (multiple-value-p (member 'multiple-value (binding-declarations b))))
 879     (when (null b)
 880       (error "Return from unknown block `~S'." (symbol-name name)))
 881     (push 'used (binding-declarations b))
 882     ;; The binding value is the name of a variable, whose value is the
 883     ;; unique identifier of the block as exception. We can't use the
 884     ;; variable name itself, because it could not to be unique, so we
 885     ;; capture it in a closure.
 886     (js!selfcall
 887       (when multiple-value-p (code "var values = mv;" *newline*))
 888       "throw ({"
 889       "type: 'block', "
 890       "id: " (binding-value b) ", "
 891       "values: " (ls-compile value multiple-value-p) ", "
 892       "message: 'Return from unknown block " (symbol-name name) ".'"
 893       "})")))
 894
 895 (define-compilation catch (id &rest body)
 896   (js!selfcall
 897     "var id = " (ls-compile id) ";" *newline*
 898     "try {" *newline*
 899     (indent (ls-compile-block body t)) *newline*
 900     "}" *newline*
 901     "catch (cf){" *newline*
 902     "    if (cf.type == 'catch' && cf.id == id)" *newline*
 903     (if *multiple-value-p*
 904         "        return values.apply(this, forcemv(cf.values));"
 905         "        return pv.apply(this, forcemv(cf.values));")
 906     *newline*
 907     "    else" *newline*
 908     "        throw cf;" *newline*
 909     "}" *newline*))
 910
 911 (define-compilation throw (id value)
 912   (js!selfcall
 913     "var values = mv;" *newline*
 914     "throw ({"
 915     "type: 'catch', "
 916     "id: " (ls-compile id) ", "
 917     "values: " (ls-compile value t) ", "
 918     "message: 'Throw uncatched.'"
 919     "})"))
 920
 921 (defun go-tag-p (x)
 922   (or (integerp x) (symbolp x)))
 923
 924 (defun declare-tagbody-tags (tbidx body)
 925   (let* ((go-tag-counter 0)
 926          (bindings
 927           (mapcar (lambda (label)
 928                     (let ((tagidx (integer-to-string (incf go-tag-counter))))
 929                       (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
 930                   (remove-if-not #'go-tag-p body))))
 931     (extend-lexenv bindings *environment* 'gotag)))
 932
 933 (define-compilation tagbody (&rest body)
 934   ;; Ignore the tagbody if it does not contain any go-tag. We do this
 935   ;; because 1) it is easy and 2) many built-in forms expand to a
 936   ;; implicit tagbody, so we save some space.
 937   (unless (some #'go-tag-p body)
 938     (return-from tagbody (ls-compile `(progn ,@body nil))))
 939   ;; The translation assumes the first form in BODY is a label
 940   (unless (go-tag-p (car body))
 941     (push (gensym "START") body))
 942   ;; Tagbody compilation
 943   (let ((branch (gvarname 'branch))
 944         (tbidx (gvarname 'tbidx)))
 945     (let ((*environment* (declare-tagbody-tags tbidx body))
 946           initag)
 947       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
 948         (setq initag (second (binding-value b))))
 949       (js!selfcall
 950         ;; TAGBODY branch to take
 951         "var " branch " = " initag ";" *newline*
 952         "var " tbidx " = [];" *newline*
 953         "tbloop:" *newline*
 954         "while (true) {" *newline*
 955         (indent "try {" *newline*
 956                 (indent (let ((content ""))
 957                           (code "switch(" branch "){" *newline*
 958                                 "case " initag ":" *newline*
 959                                 (dolist (form (cdr body) content)
 960                                   (concatf content
 961                                     (if (not (go-tag-p form))
 962                                         (indent (ls-compile form) ";" *newline*)
 963                                         (let ((b (lookup-in-lexenv form *environment* 'gotag)))
 964                                           (code "case " (second (binding-value b)) ":" *newline*)))))
 965                                 "default:" *newline*
 966                                 "    break tbloop;" *newline*
 967                                 "}" *newline*)))
 968                 "}" *newline*
 969                 "catch (jump) {" *newline*
 970                 "    if (jump.type == 'tagbody' && jump.id == " tbidx ")" *newline*
 971                 "        " branch " = jump.label;" *newline*
 972                 "    else" *newline*
 973                 "        throw(jump);" *newline*
 974                 "}" *newline*)
 975         "}" *newline*
 976         "return " (ls-compile nil) ";" *newline*))))
 977
 978 (define-compilation go (label)
 979   (let ((b (lookup-in-lexenv label *environment* 'gotag))
 980         (n (cond
 981              ((symbolp label) (symbol-name label))
 982              ((integerp label) (integer-to-string label)))))
 983     (when (null b)
 984       (error "Unknown tag `~S'" label))
 985     (js!selfcall
 986       "throw ({"
 987       "type: 'tagbody', "
 988       "id: " (first (binding-value b)) ", "
 989       "label: " (second (binding-value b)) ", "
 990       "message: 'Attempt to GO to non-existing tag " n "'"
 991       "})" *newline*)))
 992
 993 (define-compilation unwind-protect (form &rest clean-up)
 994   (js!selfcall
 995     "var ret = " (ls-compile nil) ";" *newline*
 996     "try {" *newline*
 997     (indent "ret = " (ls-compile form) ";" *newline*)
 998     "} finally {" *newline*
 999     (indent (ls-compile-block clean-up))
1000     "}" *newline*
1001     "return ret;" *newline*))
1002
1003 (define-compilation multiple-value-call (func-form &rest forms)
1004   (js!selfcall
1005     "var func = " (ls-compile func-form) ";" *newline*
1006     "var args = [" (if *multiple-value-p* "values" "pv") ", 0];" *newline*
1007     "return "
1008     (js!selfcall
1009       "var values = mv;" *newline*
1010       "var vs;" *newline*
1011       (mapconcat (lambda (form)
1012                    (code "vs = " (ls-compile form t) ";" *newline*
1013                          "if (typeof vs === 'object' && 'multiple-value' in vs)" *newline*
1014                          (indent "args = args.concat(vs);" *newline*)
1015                          "else" *newline*
1016                          (indent "args.push(vs);" *newline*)))
1017                  forms)
1018       "args[1] = args.length-2;" *newline*
1019       "return func.apply(window, args);" *newline*) ";" *newline*))
1020
1021 (define-compilation multiple-value-prog1 (first-form &rest forms)
1022   (js!selfcall
1023     "var args = " (ls-compile first-form *multiple-value-p*) ";" *newline*
1024     (ls-compile-block forms)
1025     "return args;" *newline*))
1026
1027 (define-transformation backquote (form)
1028   (bq-completely-process form))
1029
1030
1031 ;;; Primitives
1032
1033 (defvar *builtins* nil)
1034
1035 (defmacro define-raw-builtin (name args &body body)
1036   ;; Creates a new primitive function `name' with parameters args and
1037   ;; @body. The body can access to the local environment through the
1038   ;; variable *ENVIRONMENT*.
1039   `(push (list ',name (lambda ,args (block ,name ,@body)))
1040          *builtins*))
1041
1042 (defmacro define-builtin (name args &body body)
1043   `(define-raw-builtin ,name ,args
1044      (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)
1045        ,@body)))
1046
1047 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
1048 (defmacro type-check (decls &body body)
1049   `(js!selfcall
1050      ,@(mapcar (lambda (decl)
1051                  `(code "var " ,(first decl) " = " ,(third decl) ";" *newline*))
1052                decls)
1053      ,@(mapcar (lambda (decl)
1054                  `(code "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline*
1055                         (indent "throw 'The value ' + "
1056                                 ,(first decl)
1057                                 " + ' is not a type "
1058                                 ,(second decl)
1059                                 ".';"
1060                                 *newline*)))
1061                decls)
1062      (code "return " (progn ,@body) ";" *newline*)))
1063
1064 ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
1065 ;;; a variable which holds a list of forms. It will compile them and
1066 ;;; store the result in some Javascript variables. BODY is evaluated
1067 ;;; with ARGS bound to the list of these variables to generate the
1068 ;;; code which performs the transformation on these variables.
1069
1070 (defun variable-arity-call (args function)
1071   (unless (consp args)
1072     (error "ARGS must be a non-empty list"))
1073   (let ((counter 0)
1074         (fargs '())
1075         (prelude ""))
1076     (dolist (x args)
1077       (cond
1078         ((floatp x) (push (float-to-string x) fargs))
1079         ((numberp x) (push (integer-to-string x) fargs))
1080         (t (let ((v (code "x" (incf counter))))
1081              (push v fargs)
1082              (concatf prelude
1083                (code "var " v " = " (ls-compile x) ";" *newline*
1084                      "if (typeof " v " !== 'number') throw 'Not a number!';"
1085                      *newline*))))))
1086     (js!selfcall prelude (funcall function (reverse fargs)))))
1087
1088
1089 (defmacro variable-arity (args &body body)
1090   (unless (symbolp args)
1091     (error "`~S' is not a symbol." args))
1092   `(variable-arity-call ,args
1093                         (lambda (,args)
1094                           (code "return " ,@body ";" *newline*))))
1095
1096 (defun num-op-num (x op y)
1097   (type-check (("x" "number" x) ("y" "number" y))
1098     (code "x" op "y")))
1099
1100 (define-raw-builtin + (&rest numbers)
1101   (if (null numbers)
1102       "0"
1103       (variable-arity numbers
1104         (join numbers "+"))))
1105
1106 (define-raw-builtin - (x &rest others)
1107   (let ((args (cons x others)))
1108     (variable-arity args
1109       (if (null others)
1110           (concat "-" (car args))
1111           (join args "-")))))
1112
1113 (define-raw-builtin * (&rest numbers)
1114   (if (null numbers)
1115       "1"
1116       (variable-arity numbers
1117         (join numbers "*"))))
1118
1119 (define-raw-builtin / (x &rest others)
1120   (let ((args (cons x others)))
1121     (variable-arity args
1122       (if (null others)
1123           (concat "1 /" (car args))
1124           (join args "/")))))
1125
1126 (define-builtin mod (x y) (num-op-num x "%" y))
1127
1128
1129 (defun comparison-conjuntion (vars op)
1130   (cond
1131     ((null (cdr vars))
1132      "true")
1133     ((null (cddr vars))
1134      (concat (car vars) op (cadr vars)))
1135     (t
1136      (concat (car vars) op (cadr vars)
1137              " && "
1138              (comparison-conjuntion (cdr vars) op)))))
1139
1140 (defmacro define-builtin-comparison (op sym)
1141   `(define-raw-builtin ,op (x &rest args)
1142      (let ((args (cons x args)))
1143        (variable-arity args
1144          (js!bool (comparison-conjuntion args ,sym))))))
1145
1146 (define-builtin-comparison > ">")
1147 (define-builtin-comparison < "<")
1148 (define-builtin-comparison >= ">=")
1149 (define-builtin-comparison <= "<=")
1150 (define-builtin-comparison = "==")
1151 (define-builtin-comparison /= "!=")
1152
1153 (define-builtin numberp (x)
1154   (js!bool (code "(typeof (" x ") == \"number\")")))
1155
1156 (define-builtin floor (x)
1157   (type-check (("x" "number" x))
1158     "Math.floor(x)"))
1159
1160 (define-builtin expt (x y)
1161   (type-check (("x" "number" x)
1162                ("y" "number" y))
1163     "Math.pow(x, y)"))
1164
1165 (define-builtin float-to-string (x)
1166   (type-check (("x" "number" x))
1167     "make_lisp_string(x.toString())"))
1168
1169 (define-builtin cons (x y)
1170   (code "({car: " x ", cdr: " y "})"))
1171
1172 (define-builtin consp (x)
1173   (js!bool
1174    (js!selfcall
1175      "var tmp = " x ";" *newline*
1176      "return (typeof tmp == 'object' && 'car' in tmp);" *newline*)))
1177
1178 (define-builtin car (x)
1179   (js!selfcall
1180     "var tmp = " x ";" *newline*
1181     "return tmp === " (ls-compile nil)
1182     "? " (ls-compile nil)
1183     ": tmp.car;" *newline*))
1184
1185 (define-builtin cdr (x)
1186   (js!selfcall
1187     "var tmp = " x ";" *newline*
1188     "return tmp === " (ls-compile nil) "? "
1189     (ls-compile nil)
1190     ": tmp.cdr;" *newline*))
1191
1192 (define-builtin rplaca (x new)
1193   (type-check (("x" "object" x))
1194     (code "(x.car = " new ", x)")))
1195
1196 (define-builtin rplacd (x new)
1197   (type-check (("x" "object" x))
1198     (code "(x.cdr = " new ", x)")))
1199
1200 (define-builtin symbolp (x)
1201   (js!bool (code "(" x " instanceof Symbol)")))
1202
1203 (define-builtin make-symbol (name)
1204   (code "(new Symbol(" name "))"))
1205
1206 (define-builtin symbol-name (x)
1207   (code "(" x ").name"))
1208
1209 (define-builtin set (symbol value)
1210   (code "(" symbol ").value = " value))
1211
1212 (define-builtin fset (symbol value)
1213   (code "(" symbol ").fvalue = " value))
1214
1215 (define-builtin boundp (x)
1216   (js!bool (code "(" x ".value !== undefined)")))
1217
1218 (define-builtin fboundp (x)
1219   (js!bool (code "(" x ".fvalue !== undefined)")))
1220
1221 (define-builtin symbol-value (x)
1222   (js!selfcall
1223     "var symbol = " x ";" *newline*
1224     "var value = symbol.value;" *newline*
1225     "if (value === undefined) throw \"Variable `\" + xstring(symbol.name) + \"' is unbound.\";" *newline*
1226     "return value;" *newline*))
1227
1228 (define-builtin symbol-function (x)
1229   (js!selfcall
1230     "var symbol = " x ";" *newline*
1231     "var func = symbol.fvalue;" *newline*
1232     "if (func === undefined) throw \"Function `\" + xstring(symbol.name) + \"' is undefined.\";" *newline*
1233     "return func;" *newline*))
1234
1235 (define-builtin symbol-plist (x)
1236   (code "((" x ").plist || " (ls-compile nil) ")"))
1237
1238 (define-builtin lambda-code (x)
1239   (code "make_lisp_string((" x ").toString())"))
1240
1241 (define-builtin eq (x y)
1242   (js!bool (code "(" x " === " y ")")))
1243
1244 (define-builtin char-code (x)
1245   (type-check (("x" "string" x))
1246     "char_to_codepoint(x)"))
1247
1248 (define-builtin code-char (x)
1249   (type-check (("x" "number" x))
1250     "char_from_codepoint(x)"))
1251
1252 (define-builtin characterp (x)
1253   (js!bool
1254    (js!selfcall
1255      "var x = " x ";" *newline*
1256      "return (typeof(" x ") == \"string\") && (x.length == 1 || x.length == 2);")))
1257
1258 (define-builtin char-upcase (x)
1259   (code "safe_char_upcase(" x ")"))
1260
1261 (define-builtin char-downcase (x)
1262   (code "safe_char_downcase(" x ")"))
1263
1264 (define-builtin stringp (x)
1265   (js!bool
1266    (js!selfcall
1267      "var x = " x ";" *newline*
1268      "return typeof(x) == 'object' && 'length' in x && x.stringp == 1;")))
1269
1270 (define-raw-builtin funcall (func &rest args)
1271   (js!selfcall
1272     "var f = " (ls-compile func) ";" *newline*
1273     "return (typeof f === 'function'? f: f.fvalue)("
1274     (join (list* (if *multiple-value-p* "values" "pv")
1275                  (integer-to-string (length args))
1276                  (mapcar #'ls-compile args))
1277           ", ")
1278     ")"))
1279
1280 (define-raw-builtin apply (func &rest args)
1281   (if (null args)
1282       (code "(" (ls-compile func) ")()")
1283       (let ((args (butlast args))
1284             (last (car (last args))))
1285         (js!selfcall
1286           "var f = " (ls-compile func) ";" *newline*
1287           "var args = [" (join (list* (if *multiple-value-p* "values" "pv")
1288                                       (integer-to-string (length args))
1289                                       (mapcar #'ls-compile args))
1290                                ", ")
1291           "];" *newline*
1292           "var tail = (" (ls-compile last) ");" *newline*
1293           "while (tail != " (ls-compile nil) "){" *newline*
1294           "    args.push(tail.car);" *newline*
1295           "    args[1] += 1;" *newline*
1296           "    tail = tail.cdr;" *newline*
1297           "}" *newline*
1298           "return (typeof f === 'function'? f : f.fvalue).apply(this, args);" *newline*))))
1299
1300 (define-builtin js-eval (string)
1301   (if *multiple-value-p*
1302       (js!selfcall
1303         "var v = globalEval(xstring(" string "));" *newline*
1304         "return values.apply(this, forcemv(v));" *newline*)
1305       (code "globalEval(xstring(" string "))")))
1306
1307 (define-builtin %throw (string)
1308   (js!selfcall "throw " string ";" *newline*))
1309
1310 (define-builtin functionp (x)
1311   (js!bool (code "(typeof " x " == 'function')")))
1312
1313 (define-builtin write-string (x)
1314   (code "lisp.write(" x ")"))
1315
1316
1317 ;;; Storage vectors. They are used to implement arrays and (in the
1318 ;;; future) structures.
1319
1320 (define-builtin storage-vector-p (x)
1321   (js!bool
1322    (js!selfcall
1323      "var x = " x ";" *newline*
1324      "return typeof x === 'object' && 'length' in x;")))
1325
1326 (define-builtin make-storage-vector (n)
1327   (js!selfcall
1328     "var r = [];" *newline*
1329     "r.length = " n ";" *newline*
1330     "return r;" *newline*))
1331
1332 (define-builtin storage-vector-size (x)
1333   (code x ".length"))
1334
1335 (define-builtin resize-storage-vector (vector new-size)
1336   (code "(" vector ".length = " new-size ")"))
1337
1338 (define-builtin storage-vector-ref (vector n)
1339   (js!selfcall
1340     "var x = " "(" vector ")[" n "];" *newline*
1341     "if (x === undefined) throw 'Out of range';" *newline*
1342     "return x;" *newline*))
1343
1344 (define-builtin storage-vector-set (vector n value)
1345   (js!selfcall
1346     "var x = " vector ";" *newline*
1347     "var i = " n ";" *newline*
1348     "if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
1349     "return x[i] = " value ";" *newline*))
1350
1351 (define-builtin concatenate-storage-vector (sv1 sv2)
1352   (js!selfcall
1353     "var sv1 = " sv1 ";" *newline*
1354     "var r = sv1.concat(" sv2 ");" *newline*
1355     "r.type = sv1.type;" *newline*
1356     "r.stringp = sv1.stringp;" *newline*
1357     "return r;" *newline*))
1358
1359 (define-builtin get-internal-real-time ()
1360   "(new Date()).getTime()")
1361
1362 (define-builtin values-array (array)
1363   (if *multiple-value-p*
1364       (code "values.apply(this, " array ")")
1365       (code "pv.apply(this, " array ")")))
1366
1367 (define-raw-builtin values (&rest args)
1368   (if *multiple-value-p*
1369       (code "values(" (join (mapcar #'ls-compile args) ", ") ")")
1370       (code "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
1371
1372
1373 ;;; Javascript FFI
1374
1375 (define-builtin new () "{}")
1376
1377 (define-raw-builtin oget* (object key &rest keys)
1378   (js!selfcall
1379     "var tmp = (" (ls-compile object) ")[xstring(" (ls-compile key) ")];" *newline*
1380     (mapconcat (lambda (key)
1381                  (code "if (tmp === undefined) return " (ls-compile nil) ";" *newline*
1382                        "tmp = tmp[xstring(" (ls-compile key) ")];" *newline*))
1383                keys)
1384     "return tmp === undefined? " (ls-compile nil) " : tmp;" *newline*))
1385
1386 (define-raw-builtin oset* (value object key &rest keys)
1387   (let ((keys (cons key keys)))
1388     (js!selfcall
1389       "var obj = " (ls-compile object) ";" *newline*
1390       (mapconcat (lambda (key)
1391                    (code "obj = obj[xstring(" (ls-compile key) ")];"
1392                          "if (obj === undefined) throw 'Impossible to set Javascript property.';" *newline*))
1393                  (butlast keys))
1394       "var tmp = obj[xstring(" (ls-compile (car (last keys))) ")] = " (ls-compile value) ";" *newline*
1395       "return tmp === undefined? " (ls-compile nil) " : tmp;" *newline*)))
1396
1397 (define-raw-builtin oget (object key &rest keys)
1398   (code "js_to_lisp(" (ls-compile `(oget* ,object ,key ,@keys)) ")"))
1399
1400 (define-raw-builtin oset (value object key &rest keys)
1401   (ls-compile `(oset* (lisp-to-js ,value) ,object ,key ,@keys)))
1402
1403 (define-builtin objectp (x)
1404   (js!bool (code "(typeof (" x ") === 'object')")))
1405
1406 (define-builtin lisp-to-js (x) (code "lisp_to_js(" x ")"))
1407 (define-builtin js-to-lisp (x) (code "js_to_lisp(" x ")"))
1408
1409
1410 (define-builtin in (key object)
1411   (js!bool (code "(xstring(" key ") in (" object "))")))
1412
1413 (define-builtin map-for-in (function object)
1414   (js!selfcall
1415    "var f = " function ";" *newline*
1416    "var g = (typeof f === 'function' ? f : f.fvalue);" *newline*
1417    "var o = " object ";" *newline*
1418    "for (var key in o){" *newline*
1419    (indent "g(" (if *multiple-value-p* "values" "pv") ", 1, o[key]);" *newline*)
1420    "}"
1421    " return " (ls-compile nil) ";" *newline*))
1422
1423 (define-compilation %js-vref (var)
1424   (code "js_to_lisp(" var ")"))
1425
1426 (define-compilation %js-vset (var val)
1427   (code "(" var " = lisp_to_js(" (ls-compile val) "))"))
1428
1429 (define-setf-expander %js-vref (var)
1430   (let ((new-value (gensym)))
1431     (unless (stringp var)
1432       (error "`~S' is not a string." var))
1433     (values nil
1434             (list var)
1435             (list new-value)
1436             `(%js-vset ,var ,new-value)
1437             `(%js-vref ,var))))
1438
1439
1440 #-jscl
1441 (defvar *macroexpander-cache*
1442   (make-hash-table :test #'eq))
1443
1444 (defun !macro-function (symbol)
1445   (unless (symbolp symbol)
1446     (error "`~S' is not a symbol." symbol))
1447   (let ((b (lookup-in-lexenv symbol *environment* 'function)))
1448     (if (and b (eq (binding-type b) 'macro))
1449         (let ((expander (binding-value b)))
1450           (cond
1451             #-jscl
1452             ((gethash b *macroexpander-cache*)
1453              (setq expander (gethash b *macroexpander-cache*)))
1454             ((listp expander)
1455              (let ((compiled (eval expander)))
1456                ;; The list representation are useful while
1457                ;; bootstrapping, as we can dump the definition of the
1458                ;; macros easily, but they are slow because we have to
1459                ;; evaluate them and compile them now and again. So, let
1460                ;; us replace the list representation version of the
1461                ;; function with the compiled one.
1462                ;;
1463                #+jscl (setf (binding-value b) compiled)
1464                #-jscl (setf (gethash b *macroexpander-cache*) compiled)
1465                (setq expander compiled))))
1466           expander)
1467         nil)))
1468
1469 (defun !macroexpand-1 (form)
1470   (cond
1471     ((symbolp form)
1472      (let ((b (lookup-in-lexenv form *environment* 'variable)))
1473        (if (and b (eq (binding-type b) 'macro))
1474            (values (binding-value b) t)
1475            (values form nil))))
1476     ((and (consp form) (symbolp (car form)))
1477      (let ((macrofun (!macro-function (car form))))
1478        (if macrofun
1479            (values (funcall macrofun (cdr form)) t)
1480            (values form nil))))
1481     (t
1482      (values form nil))))
1483
1484 (defun compile-funcall (function args)
1485   (let* ((values-funcs (if *multiple-value-p* "values" "pv"))
1486          (arglist (concat "(" (join (list* values-funcs
1487                                            (integer-to-string (length args))
1488                                            (mapcar #'ls-compile args)) ", ") ")")))
1489     (unless (or (symbolp function)
1490                 (and (consp function)
1491                      (member (car function) '(lambda oget))))
1492       (error "Bad function designator `~S'" function))
1493     (cond
1494       ((translate-function function)
1495        (concat (translate-function function) arglist))
1496       ((and (symbolp function)
1497             #+jscl (eq (symbol-package function) (find-package "COMMON-LISP"))
1498             #-jscl t)
1499        (code (ls-compile `',function) ".fvalue" arglist))
1500       #+jscl((symbolp function)
1501        (code (ls-compile `#',function) arglist))
1502       ((and (consp function) (eq (car function) 'lambda))
1503        (code (ls-compile `#',function) arglist))
1504       ((and (consp function) (eq (car function) 'oget))
1505        (code (ls-compile function) arglist))
1506       (t
1507        (error "Bad function descriptor")))))
1508
1509 (defun ls-compile-block (sexps &optional return-last-p decls-allowed-p)
1510   (multiple-value-bind (sexps decls)
1511       (parse-body sexps :declarations decls-allowed-p)
1512     (declare (ignore decls))
1513     (if return-last-p
1514         (code (ls-compile-block (butlast sexps) nil decls-allowed-p)
1515               "return " (ls-compile (car (last sexps)) *multiple-value-p*) ";")
1516         (join-trailing
1517          (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
1518          (concat ";" *newline*)))))
1519
1520 (defun ls-compile (sexp &optional multiple-value-p)
1521   (multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp)
1522     (when expandedp
1523       (return-from ls-compile (ls-compile sexp multiple-value-p)))
1524     ;; The expression has been macroexpanded. Now compile it!
1525     (let ((*multiple-value-p* multiple-value-p))
1526       (cond
1527         ((symbolp sexp)
1528          (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
1529            (cond
1530              ((and b (not (member 'special (binding-declarations b))))
1531               (binding-value b))
1532              ((or (keywordp sexp)
1533                   (and b (member 'constant (binding-declarations b))))
1534               (code (ls-compile `',sexp) ".value"))
1535              (t
1536               (ls-compile `(symbol-value ',sexp))))))
1537         ((or (integerp sexp) (floatp sexp) (characterp sexp) (stringp sexp) (arrayp sexp))
1538          (literal sexp))
1539         ((listp sexp)
1540          (let ((name (car sexp))
1541                (args (cdr sexp)))
1542            (cond
1543              ;; Special forms
1544              ((assoc name *compilations*)
1545               (let ((comp (second (assoc name *compilations*))))
1546                 (apply comp args)))
1547              ;; Built-in functions
1548              ((and (assoc name *builtins*)
1549                    (not (claimp name 'function 'notinline)))
1550               (let ((comp (second (assoc name *builtins*))))
1551                 (apply comp args)))
1552              (t
1553               (compile-funcall name args)))))
1554         (t
1555          (error "How should I compile `~S'?" sexp))))))
1556
1557
1558 (defvar *compile-print-toplevels* nil)
1559
1560 (defun truncate-string (string &optional (width 60))
1561   (let ((n (or (position #\newline string)
1562                (min width (length string)))))
1563     (subseq string 0 n)))
1564
1565 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
1566   (let ((*toplevel-compilations* nil))
1567     (cond
1568       ((and (consp sexp) (eq (car sexp) 'progn))
1569        (let ((subs (mapcar (lambda (s)
1570                              (ls-compile-toplevel s t))
1571                            (cdr sexp))))
1572          (join (remove-if #'null-or-empty-p subs))))
1573       (t
1574        (when *compile-print-toplevels*
1575          (let ((form-string (prin1-to-string sexp)))
1576            (format t "Compiling ~a..." (truncate-string form-string))))
1577        (let ((code (ls-compile sexp multiple-value-p)))
1578          (code (join-trailing (get-toplevel-compilations)
1579                               (code ";" *newline*))
1580                (when code
1581                  (code code ";" *newline*))))))))