src/compiler.lisp

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