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 #+common-lisp
  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 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 = '" (escape-string name) "';" *newline*))
 270         (when docstring
 271           (code "func.docstring = '" (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 "for (i=" (+ n-required-arguments n-optional-arguments)
 372              "; i<nargs; i+=2){" *newline*
 373              (indent "if ("
 374                      (join (mapcar (lambda (x)
 375                                      (concat "arguments[i+2] !== " (ls-compile (caar x))))
 376                                    keyword-arguments)
 377                            " && ")
 378                      ")" *newline*
 379                      (indent
 380                       "throw 'Unknown keyword argument ' + xstring(arguments[i].name);" *newline*))
 381              "}" *newline*)))))
 382
 383 (defun parse-lambda-list (ll)
 384   (values (ll-required-arguments ll)
 385           (ll-optional-arguments ll)
 386           (ll-keyword-arguments  ll)
 387           (ll-rest-argument      ll)))
 388
 389 ;;; Process BODY for declarations and/or docstrings. Return as
 390 ;;; multiple values the BODY without docstrings or declarations, the
 391 ;;; list of declaration forms and the docstring.
 392 (defun parse-body (body &key declarations docstring)
 393   (let ((value-declarations)
 394         (value-docstring))
 395     ;; Parse declarations
 396     (when declarations
 397       (do* ((rest body (cdr rest))
 398             (form (car rest) (car rest)))
 399            ((or (atom form) (not (eq (car form) 'declare)))
 400             (setf body rest))
 401         (push form value-declarations)))
 402     ;; Parse docstring
 403     (when (and docstring
 404                (stringp (car body))
 405                (not (null (cdr body))))
 406       (setq value-docstring (car body))
 407       (setq body (cdr body)))
 408     (values body value-declarations value-docstring)))
 409
 410 ;;; Compile a lambda function with lambda list LL and body BODY. If
 411 ;;; NAME is given, it should be a constant string and it will become
 412 ;;; the name of the function. If BLOCK is non-NIL, a named block is
 413 ;;; created around the body. NOTE: No block (even anonymous) is
 414 ;;; created if BLOCk is NIL.
 415 (defun compile-lambda (ll body &key name block)
 416   (multiple-value-bind (required-arguments
 417                         optional-arguments
 418                         keyword-arguments
 419                         rest-argument)
 420       (parse-lambda-list ll)
 421     (multiple-value-bind (body decls documentation)
 422         (parse-body body :declarations t :docstring t)
 423       (declare (ignore decls))
 424       (let ((n-required-arguments (length required-arguments))
 425             (n-optional-arguments (length optional-arguments))
 426             (*environment* (extend-local-env
 427                             (append (ensure-list rest-argument)
 428                                     required-arguments
 429                                     optional-arguments
 430                                     keyword-arguments
 431                                     (ll-svars ll)))))
 432         (lambda-name/docstring-wrapper name documentation
 433          "(function ("
 434          (join (list* "values"
 435                       "nargs"
 436                       (mapcar #'translate-variable
 437                               (append required-arguments optional-arguments)))
 438                ",")
 439          "){" *newline*
 440          (indent
 441           ;; Check number of arguments
 442           (lambda-check-argument-count n-required-arguments
 443                                        n-optional-arguments
 444                                        (or rest-argument keyword-arguments))
 445                                         (compile-lambda-optional ll)
 446                                         (compile-lambda-rest ll)
 447                                         (compile-lambda-parse-keywords ll)
 448                                         (let ((*multiple-value-p* t))
 449                                           (if block
 450                                               (ls-compile-block `((block ,block ,@body)) t)
 451                                               (ls-compile-block body t))))
 452          "})")))))
 453
 454
 455 (defun setq-pair (var val)
 456   (let ((b (lookup-in-lexenv var *environment* 'variable)))
 457     (cond
 458       ((and b
 459             (eq (binding-type b) 'variable)
 460             (not (member 'special (binding-declarations b)))
 461             (not (member 'constant (binding-declarations b))))
 462        (code (binding-value b) " = " (ls-compile val)))
 463       ((and b (eq (binding-type b) 'macro))
 464        (ls-compile `(setf ,var ,val)))
 465       (t
 466        (ls-compile `(set ',var ,val))))))
 467
 468
 469 (define-compilation setq (&rest pairs)
 470   (let ((result ""))
 471     (while t
 472       (cond
 473         ((null pairs) (return))
 474         ((null (cdr pairs))
 475          (error "Odd pairs in SETQ"))
 476         (t
 477          (concatf result
 478            (concat (setq-pair (car pairs) (cadr pairs))
 479                    (if (null (cddr pairs)) "" ", ")))
 480          (setq pairs (cddr pairs)))))
 481     (code "(" result ")")))
 482
 483
 484 ;;; Compilation of literals an object dumping
 485
 486 (defun escape-string (string)
 487   (let ((output "")
 488         (index 0)
 489         (size (length string)))
 490     (while (< index size)
 491       (let ((ch (char string index)))
 492         (when (or (char= ch #\") (char= ch #\\))
 493           (setq output (concat output "\\")))
 494         (when (or (char= ch #\newline))
 495           (setq output (concat output "\\"))
 496           (setq ch #\n))
 497         (setq output (concat output (string ch))))
 498       (incf index))
 499     output))
 500
 501 (defvar *literal-table* nil)
 502 (defvar *literal-counter* 0)
 503
 504 (defun genlit ()
 505   (code "l" (incf *literal-counter*)))
 506
 507 (defun dump-symbol (symbol)
 508   #+common-lisp
 509   (let ((package (symbol-package symbol)))
 510     (if (eq package (find-package "KEYWORD"))
 511         (code "(new Symbol(" (dump-string (symbol-name symbol)) ", "
 512               (dump-string (package-name package)) "))")
 513         (code "(new Symbol(" (dump-string (symbol-name symbol)) "))")))
 514   #+jscl
 515   (let ((package (symbol-package symbol)))
 516     (if (null package)
 517         (code "(new Symbol(" (dump-string (symbol-name symbol)) "))")
 518         (ls-compile `(intern ,(symbol-name symbol) ,(package-name package))))))
 519
 520 (defun dump-cons (cons)
 521   (let ((head (butlast cons))
 522         (tail (last cons)))
 523     (code "QIList("
 524           (join-trailing (mapcar (lambda (x) (literal x t)) head) ",")
 525           (literal (car tail) t)
 526           ","
 527           (literal (cdr tail) t)
 528           ")")))
 529
 530 (defun dump-array (array)
 531   (let ((elements (vector-to-list array)))
 532     (concat "[" (join (mapcar #'literal elements) ", ") "]")))
 533
 534 (defun dump-string (string)
 535   (code "make_lisp_string(\"" (escape-string string) "\")"))
 536
 537 (defun literal (sexp &optional recursive)
 538   (cond
 539     ((integerp sexp) (integer-to-string sexp))
 540     ((floatp sexp) (float-to-string sexp))
 541     ((characterp sexp) (code "\"" (escape-string (string sexp)) "\""))
 542     (t
 543      (or (cdr (assoc sexp *literal-table* :test #'equal))
 544          (let ((dumped (typecase sexp
 545                          (symbol (dump-symbol sexp))
 546                          (string (dump-string sexp))
 547                          (cons
 548                           ;; BOOTSTRAP MAGIC: See the root file
 549                           ;; jscl.lisp and the function
 550                           ;; `dump-global-environment' for futher
 551                           ;; information.
 552                           (if (eq (car sexp) *magic-unquote-marker*)
 553                               (ls-compile (second sexp))
 554                               (dump-cons sexp)))
 555                          (array (dump-array sexp)))))
 556            (if (and recursive (not (symbolp sexp)))
 557                dumped
 558                (let ((jsvar (genlit)))
 559                  (push (cons sexp jsvar) *literal-table*)
 560                  (toplevel-compilation (code "var " jsvar " = " dumped))
 561                  jsvar)))))))
 562
 563
 564 (define-compilation quote (sexp)
 565   (literal sexp))
 566
 567 (define-compilation %while (pred &rest body)
 568   (js!selfcall
 569     "while(" (ls-compile pred) " !== " (ls-compile nil) "){" *newline*
 570     (indent (ls-compile-block body))
 571     "}"
 572     "return " (ls-compile nil) ";" *newline*))
 573
 574 (define-compilation function (x)
 575   (cond
 576     ((and (listp x) (eq (car x) 'lambda))
 577      (compile-lambda (cadr x) (cddr x)))
 578     ((and (listp x) (eq (car x) 'named-lambda))
 579      ;; TODO: destructuring-bind now! Do error checking manually is
 580      ;; very annoying.
 581      (let ((name (cadr x))
 582            (ll (caddr x))
 583            (body (cdddr x)))
 584        (compile-lambda ll body
 585                        :name (symbol-name name)
 586                        :block name)))
 587     ((symbolp x)
 588      (let ((b (lookup-in-lexenv x *environment* 'function)))
 589        (if b
 590            (binding-value b)
 591            (ls-compile `(symbol-function ',x)))))))
 592
 593
 594 (defun make-function-binding (fname)
 595   (make-binding :name fname :type 'function :value (gvarname fname)))
 596
 597 (defun compile-function-definition (list)
 598   (compile-lambda (car list) (cdr list)))
 599
 600 (defun translate-function (name)
 601   (let ((b (lookup-in-lexenv name *environment* 'function)))
 602     (and b (binding-value b))))
 603
 604 (define-compilation flet (definitions &rest body)
 605   (let* ((fnames (mapcar #'car definitions))
 606          (cfuncs (mapcar (lambda (def)
 607                            (compile-lambda (cadr def)
 608                                            `((block ,(car def)
 609                                                ,@(cddr def)))))
 610                          definitions))
 611          (*environment*
 612           (extend-lexenv (mapcar #'make-function-binding fnames)
 613                          *environment*
 614                          'function)))
 615     (code "(function("
 616           (join (mapcar #'translate-function fnames) ",")
 617           "){" *newline*
 618           (let ((body (ls-compile-block body t)))
 619             (indent body))
 620           "})(" (join cfuncs ",") ")")))
 621
 622 (define-compilation labels (definitions &rest body)
 623   (let* ((fnames (mapcar #'car definitions))
 624          (*environment*
 625           (extend-lexenv (mapcar #'make-function-binding fnames)
 626                          *environment*
 627                          'function)))
 628     (js!selfcall
 629       (mapconcat (lambda (func)
 630                    (code "var " (translate-function (car func))
 631                          " = " (compile-lambda (cadr func)
 632                                                `((block ,(car func) ,@(cddr func))))
 633                          ";" *newline*))
 634                  definitions)
 635       (ls-compile-block body t))))
 636
 637
 638 (defvar *compiling-file* nil)
 639 (define-compilation eval-when-compile (&rest body)
 640   (if *compiling-file*
 641       (progn
 642         (eval (cons 'progn body))
 643         nil)
 644       (ls-compile `(progn ,@body))))
 645
 646 (defmacro define-transformation (name args form)
 647   `(define-compilation ,name ,args
 648      (ls-compile ,form)))
 649
 650 (define-compilation progn (&rest body)
 651   (if (null (cdr body))
 652       (ls-compile (car body) *multiple-value-p*)
 653       (js!selfcall (ls-compile-block body t))))
 654
 655 (defun special-variable-p (x)
 656   (and (claimp x 'variable 'special) t))
 657
 658 ;;; Wrap CODE to restore the symbol values of the dynamic
 659 ;;; bindings. BINDINGS is a list of pairs of the form
 660 ;;; (SYMBOL . PLACE),  where PLACE is a Javascript variable
 661 ;;; name to initialize the symbol value and where to stored
 662 ;;; the old value.
 663 (defun let-binding-wrapper (bindings body)
 664   (when (null bindings)
 665     (return-from let-binding-wrapper body))
 666   (code
 667    "try {" *newline*
 668    (indent "var tmp;" *newline*
 669            (mapconcat
 670             (lambda (b)
 671               (let ((s (ls-compile `(quote ,(car b)))))
 672                 (code "tmp = " s ".value;" *newline*
 673                       s ".value = " (cdr b) ";" *newline*
 674                       (cdr b) " = tmp;" *newline*)))
 675             bindings)
 676            body *newline*)
 677    "}" *newline*
 678    "finally {"  *newline*
 679    (indent
 680     (mapconcat (lambda (b)
 681                  (let ((s (ls-compile `(quote ,(car b)))))
 682                    (code s ".value" " = " (cdr b) ";" *newline*)))
 683                bindings))
 684    "}" *newline*))
 685
 686 (define-compilation let (bindings &rest body)
 687   (let* ((bindings (mapcar #'ensure-list bindings))
 688          (variables (mapcar #'first bindings))
 689          (cvalues (mapcar #'ls-compile (mapcar #'second bindings)))
 690          (*environment* (extend-local-env (remove-if #'special-variable-p variables)))
 691          (dynamic-bindings))
 692     (code "(function("
 693           (join (mapcar (lambda (x)
 694                           (if (special-variable-p x)
 695                               (let ((v (gvarname x)))
 696                                 (push (cons x v) dynamic-bindings)
 697                                 v)
 698                               (translate-variable x)))
 699                         variables)
 700                 ",")
 701           "){" *newline*
 702           (let ((body (ls-compile-block body t)))
 703             (indent (let-binding-wrapper dynamic-bindings body)))
 704           "})(" (join cvalues ",") ")")))
 705
 706
 707 ;;; Return the code to initialize BINDING, and push it extending the
 708 ;;; current lexical environment if the variable is not special.
 709 (defun let*-initialize-value (binding)
 710   (let ((var (first binding))
 711         (value (second binding)))
 712     (if (special-variable-p var)
 713         (code (ls-compile `(setq ,var ,value)) ";" *newline*)
 714         (let* ((v (gvarname var))
 715                (b (make-binding :name var :type 'variable :value v)))
 716           (prog1 (code "var " v " = " (ls-compile value) ";" *newline*)
 717             (push-to-lexenv b *environment* 'variable))))))
 718
 719 ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It
 720 ;;; DOES NOT generate code to initialize the value of the symbols,
 721 ;;; unlike let-binding-wrapper.
 722 (defun let*-binding-wrapper (symbols body)
 723   (when (null symbols)
 724     (return-from let*-binding-wrapper body))
 725   (let ((store (mapcar (lambda (s) (cons s (gvarname s)))
 726                        (remove-if-not #'special-variable-p symbols))))
 727     (code
 728      "try {" *newline*
 729      (indent
 730       (mapconcat (lambda (b)
 731                    (let ((s (ls-compile `(quote ,(car b)))))
 732                      (code "var " (cdr b) " = " s ".value;" *newline*)))
 733                  store)
 734       body)
 735      "}" *newline*
 736      "finally {" *newline*
 737      (indent
 738       (mapconcat (lambda (b)
 739                    (let ((s (ls-compile `(quote ,(car b)))))
 740                      (code s ".value" " = " (cdr b) ";" *newline*)))
 741                  store))
 742      "}" *newline*)))
 743
 744 (define-compilation let* (bindings &rest body)
 745   (let ((bindings (mapcar #'ensure-list bindings))
 746         (*environment* (copy-lexenv *environment*)))
 747     (js!selfcall
 748       (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
 749             (body (concat (mapconcat #'let*-initialize-value bindings)
 750                           (ls-compile-block body t))))
 751         (let*-binding-wrapper specials body)))))
 752
 753
 754 (define-compilation block (name &rest body)
 755   ;; We use Javascript exceptions to implement non local control
 756   ;; transfer. Exceptions has dynamic scoping, so we use a uniquely
 757   ;; generated object to identify the block. The instance of a empty
 758   ;; array is used to distinguish between nested dynamic Javascript
 759   ;; exceptions. See https://github.com/davazp/jscl/issues/64 for
 760   ;; futher details.
 761   (let* ((idvar (gvarname name))
 762          (b (make-binding :name name :type 'block :value idvar)))
 763     (when *multiple-value-p*
 764       (push 'multiple-value (binding-declarations b)))
 765     (let* ((*environment* (extend-lexenv (list b) *environment* 'block))
 766            (cbody (ls-compile-block body t)))
 767       (if (member 'used (binding-declarations b))
 768           (js!selfcall
 769             "try {" *newline*
 770             "var " idvar " = [];" *newline*
 771             (indent cbody)
 772             "}" *newline*
 773             "catch (cf){" *newline*
 774             "    if (cf.type == 'block' && cf.id == " idvar ")" *newline*
 775             (if *multiple-value-p*
 776                 "        return values.apply(this, forcemv(cf.values));"
 777                 "        return cf.values;")
 778             *newline*
 779             "    else" *newline*
 780             "        throw cf;" *newline*
 781             "}" *newline*)
 782           (js!selfcall cbody)))))
 783
 784 (define-compilation return-from (name &optional value)
 785   (let* ((b (lookup-in-lexenv name *environment* 'block))
 786          (multiple-value-p (member 'multiple-value (binding-declarations b))))
 787     (when (null b)
 788       (error "Return from unknown block `~S'." (symbol-name name)))
 789     (push 'used (binding-declarations b))
 790     ;; The binding value is the name of a variable, whose value is the
 791     ;; unique identifier of the block as exception. We can't use the
 792     ;; variable name itself, because it could not to be unique, so we
 793     ;; capture it in a closure.
 794     (js!selfcall
 795       (when multiple-value-p (code "var values = mv;" *newline*))
 796       "throw ({"
 797       "type: 'block', "
 798       "id: " (binding-value b) ", "
 799       "values: " (ls-compile value multiple-value-p) ", "
 800       "message: 'Return from unknown block " (symbol-name name) ".'"
 801       "})")))
 802
 803 (define-compilation catch (id &rest body)
 804   (js!selfcall
 805     "var id = " (ls-compile id) ";" *newline*
 806     "try {" *newline*
 807     (indent (ls-compile-block body t)) *newline*
 808     "}" *newline*
 809     "catch (cf){" *newline*
 810     "    if (cf.type == 'catch' && cf.id == id)" *newline*
 811     (if *multiple-value-p*
 812         "        return values.apply(this, forcemv(cf.values));"
 813         "        return pv.apply(this, forcemv(cf.values));")
 814     *newline*
 815     "    else" *newline*
 816     "        throw cf;" *newline*
 817     "}" *newline*))
 818
 819 (define-compilation throw (id value)
 820   (js!selfcall
 821     "var values = mv;" *newline*
 822     "throw ({"
 823     "type: 'catch', "
 824     "id: " (ls-compile id) ", "
 825     "values: " (ls-compile value t) ", "
 826     "message: 'Throw uncatched.'"
 827     "})"))
 828
 829 (defun go-tag-p (x)
 830   (or (integerp x) (symbolp x)))
 831
 832 (defun declare-tagbody-tags (tbidx body)
 833   (let* ((go-tag-counter 0)
 834          (bindings
 835           (mapcar (lambda (label)
 836                     (let ((tagidx (integer-to-string (incf go-tag-counter))))
 837                       (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
 838                   (remove-if-not #'go-tag-p body))))
 839     (extend-lexenv bindings *environment* 'gotag)))
 840
 841 (define-compilation tagbody (&rest body)
 842   ;; Ignore the tagbody if it does not contain any go-tag. We do this
 843   ;; because 1) it is easy and 2) many built-in forms expand to a
 844   ;; implicit tagbody, so we save some space.
 845   (unless (some #'go-tag-p body)
 846     (return-from tagbody (ls-compile `(progn ,@body nil))))
 847   ;; The translation assumes the first form in BODY is a label
 848   (unless (go-tag-p (car body))
 849     (push (gensym "START") body))
 850   ;; Tagbody compilation
 851   (let ((branch (gvarname 'branch))
 852         (tbidx (gvarname 'tbidx)))
 853     (let ((*environment* (declare-tagbody-tags tbidx body))
 854           initag)
 855       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
 856         (setq initag (second (binding-value b))))
 857       (js!selfcall
 858         ;; TAGBODY branch to take
 859         "var " branch " = " initag ";" *newline*
 860         "var " tbidx " = [];" *newline*
 861         "tbloop:" *newline*
 862         "while (true) {" *newline*
 863         (indent "try {" *newline*
 864                 (indent (let ((content ""))
 865                           (code "switch(" branch "){" *newline*
 866                                 "case " initag ":" *newline*
 867                                 (dolist (form (cdr body) content)
 868                                   (concatf content
 869                                     (if (not (go-tag-p form))
 870                                         (indent (ls-compile form) ";" *newline*)
 871                                         (let ((b (lookup-in-lexenv form *environment* 'gotag)))
 872                                           (code "case " (second (binding-value b)) ":" *newline*)))))
 873                                 "default:" *newline*
 874                                 "    break tbloop;" *newline*
 875                                 "}" *newline*)))
 876                 "}" *newline*
 877                 "catch (jump) {" *newline*
 878                 "    if (jump.type == 'tagbody' && jump.id == " tbidx ")" *newline*
 879                 "        " branch " = jump.label;" *newline*
 880                 "    else" *newline*
 881                 "        throw(jump);" *newline*
 882                 "}" *newline*)
 883         "}" *newline*
 884         "return " (ls-compile nil) ";" *newline*))))
 885
 886 (define-compilation go (label)
 887   (let ((b (lookup-in-lexenv label *environment* 'gotag))
 888         (n (cond
 889              ((symbolp label) (symbol-name label))
 890              ((integerp label) (integer-to-string label)))))
 891     (when (null b)
 892       (error "Unknown tag `~S'" label))
 893     (js!selfcall
 894       "throw ({"
 895       "type: 'tagbody', "
 896       "id: " (first (binding-value b)) ", "
 897       "label: " (second (binding-value b)) ", "
 898       "message: 'Attempt to GO to non-existing tag " n "'"
 899       "})" *newline*)))
 900
 901 (define-compilation unwind-protect (form &rest clean-up)
 902   (js!selfcall
 903     "var ret = " (ls-compile nil) ";" *newline*
 904     "try {" *newline*
 905     (indent "ret = " (ls-compile form) ";" *newline*)
 906     "} finally {" *newline*
 907     (indent (ls-compile-block clean-up))
 908     "}" *newline*
 909     "return ret;" *newline*))
 910
 911 (define-compilation multiple-value-call (func-form &rest forms)
 912   (js!selfcall
 913     "var func = " (ls-compile func-form) ";" *newline*
 914     "var args = [" (if *multiple-value-p* "values" "pv") ", 0];" *newline*
 915     "return "
 916     (js!selfcall
 917       "var values = mv;" *newline*
 918       "var vs;" *newline*
 919       (mapconcat (lambda (form)
 920                    (code "vs = " (ls-compile form t) ";" *newline*
 921                          "if (typeof vs === 'object' && 'multiple-value' in vs)" *newline*
 922                          (indent "args = args.concat(vs);" *newline*)
 923                          "else" *newline*
 924                          (indent "args.push(vs);" *newline*)))
 925                  forms)
 926       "args[1] = args.length-2;" *newline*
 927       "return func.apply(window, args);" *newline*) ";" *newline*))
 928
 929 (define-compilation multiple-value-prog1 (first-form &rest forms)
 930   (js!selfcall
 931     "var args = " (ls-compile first-form *multiple-value-p*) ";" *newline*
 932     (ls-compile-block forms)
 933     "return args;" *newline*))
 934
 935
 936 ;;; Backquote implementation.
 937 ;;;
 938 ;;;    Author: Guy L. Steele Jr.     Date: 27 December 1985
 939 ;;;    Tested under Symbolics Common Lisp and Lucid Common Lisp.
 940 ;;;    This software is in the public domain.
 941
 942 ;;;    The following are unique tokens used during processing.
 943 ;;;    They need not be symbols; they need not even be atoms.
 944 (defvar *comma* 'unquote)
 945 (defvar *comma-atsign* 'unquote-splicing)
 946
 947 (defvar *bq-list* (make-symbol "BQ-LIST"))
 948 (defvar *bq-append* (make-symbol "BQ-APPEND"))
 949 (defvar *bq-list** (make-symbol "BQ-LIST*"))
 950 (defvar *bq-nconc* (make-symbol "BQ-NCONC"))
 951 (defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
 952 (defvar *bq-quote* (make-symbol "BQ-QUOTE"))
 953 (defvar *bq-quote-nil* (list *bq-quote* nil))
 954
 955 ;;; BACKQUOTE is an ordinary macro (not a read-macro) that processes
 956 ;;; the expression foo, looking for occurrences of #:COMMA,
 957 ;;; #:COMMA-ATSIGN, and #:COMMA-DOT.  It constructs code in strict
 958 ;;; accordance with the rules on pages 349-350 of the first edition
 959 ;;; (pages 528-529 of this second edition).  It then optionally
 960 ;;; applies a code simplifier.
 961
 962 ;;; If the value of *BQ-SIMPLIFY* is non-NIL, then BACKQUOTE
 963 ;;; processing applies the code simplifier.  If the value is NIL,
 964 ;;; then the code resulting from BACKQUOTE is exactly that
 965 ;;; specified by the official rules.
 966 (defparameter *bq-simplify* t)
 967
 968 (defmacro backquote (x)
 969   (bq-completely-process x))
 970
 971 ;;; Backquote processing proceeds in three stages:
 972 ;;;
 973 ;;; (1) BQ-PROCESS applies the rules to remove occurrences of
 974 ;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to
 975 ;;; this level of BACKQUOTE.  (It also causes embedded calls to
 976 ;;; BACKQUOTE to be expanded so that nesting is properly handled.)
 977 ;;; Code is produced that is expressed in terms of functions
 978 ;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE.  This is done
 979 ;;; so that the simplifier will simplify only list construction
 980 ;;; functions actually generated by BACKQUOTE and will not involve
 981 ;;; any user code in the simplification.  #:BQ-LIST means LIST,
 982 ;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY
 983 ;;; but indicates places where "%." was used and where NCONC may
 984 ;;; therefore be introduced by the simplifier for efficiency.
 985 ;;;
 986 ;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by
 987 ;;; BQ-PROCESS to produce equivalent but faster code.  The
 988 ;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be
 989 ;;; introduced into the code.
 990 ;;;
 991 ;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces
 992 ;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on.
 993 ;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being
 994 ;;; replaced by its argument).  #:BQ-LIST* is replaced by either
 995 ;;; LIST* or CONS (the latter is used in the two-argument case,
 996 ;;; purely to make the resulting code a tad more readable).
 997
 998 (defun bq-completely-process (x)
 999   (let ((raw-result (bq-process x)))
1000     (bq-remove-tokens (if *bq-simplify*
1001                           (bq-simplify raw-result)
1002                           raw-result))))
1003
1004 (defun bq-process (x)
1005   (cond ((atom x)
1006          (list *bq-quote* x))
1007         ((eq (car x) 'backquote)
1008          (bq-process (bq-completely-process (cadr x))))
1009         ((eq (car x) *comma*) (cadr x))
1010         ((eq (car x) *comma-atsign*)
1011          (error ",@~S after `" (cadr x)))
1012         ;; ((eq (car x) *comma-dot*)
1013         ;;  ;; (error ",.~S after `" (cadr x))
1014         ;;  (error "ill-formed"))
1015         (t (do ((p x (cdr p))
1016                 (q '() (cons (bracket (car p)) q)))
1017                ((atom p)
1018                 (cons *bq-append*
1019                       (nreconc q (list (list *bq-quote* p)))))
1020              (when (eq (car p) *comma*)
1021                (unless (null (cddr p))
1022                  (error "Malformed ,~S" p))
1023                (return (cons *bq-append*
1024                              (nreconc q (list (cadr p))))))
1025              (when (eq (car p) *comma-atsign*)
1026                (error "Dotted ,@~S" p))
1027              ;; (when (eq (car p) *comma-dot*)
1028              ;;   ;; (error "Dotted ,.~S" p)
1029              ;;   (error "Dotted"))
1030              ))))
1031
1032 ;;; This implements the bracket operator of the formal rules.
1033 (defun bracket (x)
1034   (cond ((atom x)
1035          (list *bq-list* (bq-process x)))
1036         ((eq (car x) *comma*)
1037          (list *bq-list* (cadr x)))
1038         ((eq (car x) *comma-atsign*)
1039          (cadr x))
1040         ;; ((eq (car x) *comma-dot*)
1041         ;;  (list *bq-clobberable* (cadr x)))
1042         (t (list *bq-list* (bq-process x)))))
1043
1044 ;;; This auxiliary function is like MAPCAR but has two extra
1045 ;;; purposes: (1) it handles dotted lists; (2) it tries to make
1046 ;;; the result share with the argument x as much as possible.
1047 (defun maptree (fn x)
1048   (if (atom x)
1049       (funcall fn x)
1050       (let ((a (funcall fn (car x)))
1051             (d (maptree fn (cdr x))))
1052         (if (and (eql a (car x)) (eql d (cdr x)))
1053             x
1054             (cons a d)))))
1055
1056 ;;; This predicate is true of a form that when read looked
1057 ;;; like %@foo or %.foo.
1058 (defun bq-splicing-frob (x)
1059   (and (consp x)
1060        (or (eq (car x) *comma-atsign*)
1061            ;; (eq (car x) *comma-dot*)
1062            )))
1063
1064 ;;; This predicate is true of a form that when read
1065 ;;; looked like %@foo or %.foo or just plain %foo.
1066 (defun bq-frob (x)
1067   (and (consp x)
1068        (or (eq (car x) *comma*)
1069            (eq (car x) *comma-atsign*)
1070            ;; (eq (car x) *comma-dot*)
1071            )))
1072
1073 ;;; The simplifier essentially looks for calls to #:BQ-APPEND and
1074 ;;; tries to simplify them.  The arguments to #:BQ-APPEND are
1075 ;;; processed from right to left, building up a replacement form.
1076 ;;; At each step a number of special cases are handled that,
1077 ;;; loosely speaking, look like this:
1078 ;;;
1079 ;;;  (APPEND (LIST a b c) foo) => (LIST* a b c foo)
1080 ;;;       provided a, b, c are not splicing frobs
1081 ;;;  (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo))
1082 ;;;       provided a, b, c are not splicing frobs
1083 ;;;  (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo)
1084 ;;;  (APPEND (CLOBBERABLE x) foo) => (NCONC x foo)
1085 (defun bq-simplify (x)
1086   (if (atom x)
1087       x
1088       (let ((x (if (eq (car x) *bq-quote*)
1089                    x
1090                    (maptree #'bq-simplify x))))
1091         (if (not (eq (car x) *bq-append*))
1092             x
1093             (bq-simplify-args x)))))
1094
1095 (defun bq-simplify-args (x)
1096   (do ((args (reverse (cdr x)) (cdr args))
1097        (result
1098          nil
1099          (cond ((atom (car args))
1100                 (bq-attach-append *bq-append* (car args) result))
1101                ((and (eq (caar args) *bq-list*)
1102                      (notany #'bq-splicing-frob (cdar args)))
1103                 (bq-attach-conses (cdar args) result))
1104                ((and (eq (caar args) *bq-list**)
1105                      (notany #'bq-splicing-frob (cdar args)))
1106                 (bq-attach-conses
1107                   (reverse (cdr (reverse (cdar args))))
1108                   (bq-attach-append *bq-append*
1109                                     (car (last (car args)))
1110                                     result)))
1111                ((and (eq (caar args) *bq-quote*)
1112                      (consp (cadar args))
1113                      (not (bq-frob (cadar args)))
1114                      (null (cddar args)))
1115                 (bq-attach-conses (list (list *bq-quote*
1116                                               (caadar args)))
1117                                   result))
1118                ((eq (caar args) *bq-clobberable*)
1119                 (bq-attach-append *bq-nconc* (cadar args) result))
1120                (t (bq-attach-append *bq-append*
1121                                     (car args)
1122                                     result)))))
1123       ((null args) result)))
1124
1125 (defun null-or-quoted (x)
1126   (or (null x) (and (consp x) (eq (car x) *bq-quote*))))
1127
1128 ;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND
1129 ;;; or #:BQ-NCONC.  This produces a form (op item result) but
1130 ;;; some simplifications are done on the fly:
1131 ;;;
1132 ;;;  (op '(a b c) '(d e f g)) => '(a b c d e f g)
1133 ;;;  (op item 'nil) => item, provided item is not a splicable frob
1134 ;;;  (op item 'nil) => (op item), if item is a splicable frob
1135 ;;;  (op item (op a b c)) => (op item a b c)
1136 (defun bq-attach-append (op item result)
1137   (cond ((and (null-or-quoted item) (null-or-quoted result))
1138          (list *bq-quote* (append (cadr item) (cadr result))))
1139         ((or (null result) (equal result *bq-quote-nil*))
1140          (if (bq-splicing-frob item) (list op item) item))
1141         ((and (consp result) (eq (car result) op))
1142          (list* (car result) item (cdr result)))
1143         (t (list op item result))))
1144
1145 ;;; The effect of BQ-ATTACH-CONSES is to produce a form as if by
1146 ;;; `(LIST* ,@items ,result) but some simplifications are done
1147 ;;; on the fly.
1148 ;;;
1149 ;;;  (LIST* 'a 'b 'c 'd) => '(a b c . d)
1150 ;;;  (LIST* a b c 'nil) => (LIST a b c)
1151 ;;;  (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g)
1152 ;;;  (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g)
1153 (defun bq-attach-conses (items result)
1154   (cond ((and (every #'null-or-quoted items)
1155               (null-or-quoted result))
1156          (list *bq-quote*
1157                (append (mapcar #'cadr items) (cadr result))))
1158         ((or (null result) (equal result *bq-quote-nil*))
1159          (cons *bq-list* items))
1160         ((and (consp result)
1161               (or (eq (car result) *bq-list*)
1162                   (eq (car result) *bq-list**)))
1163          (cons (car result) (append items (cdr result))))
1164         (t (cons *bq-list** (append items (list result))))))
1165
1166 ;;; Removes funny tokens and changes (#:BQ-LIST* a b) into
1167 ;;; (CONS a b) instead of (LIST* a b), purely for readability.
1168 (defun bq-remove-tokens (x)
1169   (cond ((eq x *bq-list*) 'list)
1170         ((eq x *bq-append*) 'append)
1171         ((eq x *bq-nconc*) 'nconc)
1172         ((eq x *bq-list**) 'list*)
1173         ((eq x *bq-quote*) 'quote)
1174         ((atom x) x)
1175         ((eq (car x) *bq-clobberable*)
1176          (bq-remove-tokens (cadr x)))
1177         ((and (eq (car x) *bq-list**)
1178               (consp (cddr x))
1179               (null (cdddr x)))
1180          (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
1181         (t (maptree #'bq-remove-tokens x))))
1182
1183 (define-transformation backquote (form)
1184   (bq-completely-process form))
1185
1186
1187 ;;; Primitives
1188
1189 (defvar *builtins* nil)
1190
1191 (defmacro define-raw-builtin (name args &body body)
1192   ;; Creates a new primitive function `name' with parameters args and
1193   ;; @body. The body can access to the local environment through the
1194   ;; variable *ENVIRONMENT*.
1195   `(push (list ',name (lambda ,args (block ,name ,@body)))
1196          *builtins*))
1197
1198 (defmacro define-builtin (name args &body body)
1199   `(define-raw-builtin ,name ,args
1200      (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)
1201        ,@body)))
1202
1203 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
1204 (defmacro type-check (decls &body body)
1205   `(js!selfcall
1206      ,@(mapcar (lambda (decl)
1207                  `(code "var " ,(first decl) " = " ,(third decl) ";" *newline*))
1208                decls)
1209      ,@(mapcar (lambda (decl)
1210                  `(code "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline*
1211                         (indent "throw 'The value ' + "
1212                                 ,(first decl)
1213                                 " + ' is not a type "
1214                                 ,(second decl)
1215                                 ".';"
1216                                 *newline*)))
1217                decls)
1218      (code "return " (progn ,@body) ";" *newline*)))
1219
1220 ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
1221 ;;; a variable which holds a list of forms. It will compile them and
1222 ;;; store the result in some Javascript variables. BODY is evaluated
1223 ;;; with ARGS bound to the list of these variables to generate the
1224 ;;; code which performs the transformation on these variables.
1225
1226 (defun variable-arity-call (args function)
1227   (unless (consp args)
1228     (error "ARGS must be a non-empty list"))
1229   (let ((counter 0)
1230         (fargs '())
1231         (prelude ""))
1232     (dolist (x args)
1233       (cond
1234         ((floatp x) (push (float-to-string x) fargs))
1235         ((numberp x) (push (integer-to-string x) fargs))
1236         (t (let ((v (code "x" (incf counter))))
1237              (push v fargs)
1238              (concatf prelude
1239                (code "var " v " = " (ls-compile x) ";" *newline*
1240                      "if (typeof " v " !== 'number') throw 'Not a number!';"
1241                      *newline*))))))
1242     (js!selfcall prelude (funcall function (reverse fargs)))))
1243
1244
1245 (defmacro variable-arity (args &body body)
1246   (unless (symbolp args)
1247     (error "`~S' is not a symbol." args))
1248   `(variable-arity-call ,args
1249                         (lambda (,args)
1250                           (code "return " ,@body ";" *newline*))))
1251
1252 (defun num-op-num (x op y)
1253   (type-check (("x" "number" x) ("y" "number" y))
1254     (code "x" op "y")))
1255
1256 (define-raw-builtin + (&rest numbers)
1257   (if (null numbers)
1258       "0"
1259       (variable-arity numbers
1260         (join numbers "+"))))
1261
1262 (define-raw-builtin - (x &rest others)
1263   (let ((args (cons x others)))
1264     (variable-arity args
1265       (if (null others)
1266           (concat "-" (car args))
1267           (join args "-")))))
1268
1269 (define-raw-builtin * (&rest numbers)
1270   (if (null numbers)
1271       "1"
1272       (variable-arity numbers
1273         (join numbers "*"))))
1274
1275 (define-raw-builtin / (x &rest others)
1276   (let ((args (cons x others)))
1277     (variable-arity args
1278       (if (null others)
1279           (concat "1 /" (car args))
1280           (join args "/")))))
1281
1282 (define-builtin mod (x y) (num-op-num x "%" y))
1283
1284
1285 (defun comparison-conjuntion (vars op)
1286   (cond
1287     ((null (cdr vars))
1288      "true")
1289     ((null (cddr vars))
1290      (concat (car vars) op (cadr vars)))
1291     (t
1292      (concat (car vars) op (cadr vars)
1293              " && "
1294              (comparison-conjuntion (cdr vars) op)))))
1295
1296 (defmacro define-builtin-comparison (op sym)
1297   `(define-raw-builtin ,op (x &rest args)
1298      (let ((args (cons x args)))
1299        (variable-arity args
1300          (js!bool (comparison-conjuntion args ,sym))))))
1301
1302 (define-builtin-comparison > ">")
1303 (define-builtin-comparison < "<")
1304 (define-builtin-comparison >= ">=")
1305 (define-builtin-comparison <= "<=")
1306 (define-builtin-comparison = "==")
1307
1308 (define-builtin numberp (x)
1309   (js!bool (code "(typeof (" x ") == \"number\")")))
1310
1311 (define-builtin floor (x)
1312   (type-check (("x" "number" x))
1313     "Math.floor(x)"))
1314
1315 (define-builtin expt (x y)
1316   (type-check (("x" "number" x)
1317                ("y" "number" y))
1318     "Math.pow(x, y)"))
1319
1320 (define-builtin float-to-string (x)
1321   (type-check (("x" "number" x))
1322     "make_lisp_string(x.toString())"))
1323
1324 (define-builtin cons (x y)
1325   (code "({car: " x ", cdr: " y "})"))
1326
1327 (define-builtin consp (x)
1328   (js!bool
1329    (js!selfcall
1330      "var tmp = " x ";" *newline*
1331      "return (typeof tmp == 'object' && 'car' in tmp);" *newline*)))
1332
1333 (define-builtin car (x)
1334   (js!selfcall
1335     "var tmp = " x ";" *newline*
1336     "return tmp === " (ls-compile nil)
1337     "? " (ls-compile nil)
1338     ": tmp.car;" *newline*))
1339
1340 (define-builtin cdr (x)
1341   (js!selfcall
1342     "var tmp = " x ";" *newline*
1343     "return tmp === " (ls-compile nil) "? "
1344     (ls-compile nil)
1345     ": tmp.cdr;" *newline*))
1346
1347 (define-builtin rplaca (x new)
1348   (type-check (("x" "object" x))
1349     (code "(x.car = " new ", x)")))
1350
1351 (define-builtin rplacd (x new)
1352   (type-check (("x" "object" x))
1353     (code "(x.cdr = " new ", x)")))
1354
1355 (define-builtin symbolp (x)
1356   (js!bool (code "(" x " instanceof Symbol)")))
1357
1358 (define-builtin make-symbol (name)
1359   (code "(new Symbol(" name "))"))
1360
1361 (define-builtin symbol-name (x)
1362   (code "(" x ").name"))
1363
1364 (define-builtin set (symbol value)
1365   (code "(" symbol ").value = " value))
1366
1367 (define-builtin fset (symbol value)
1368   (code "(" symbol ").fvalue = " value))
1369
1370 (define-builtin boundp (x)
1371   (js!bool (code "(" x ".value !== undefined)")))
1372
1373 (define-builtin symbol-value (x)
1374   (js!selfcall
1375     "var symbol = " x ";" *newline*
1376     "var value = symbol.value;" *newline*
1377     "if (value === undefined) throw \"Variable `\" + xstring(symbol.name) + \"' is unbound.\";" *newline*
1378     "return value;" *newline*))
1379
1380 (define-builtin symbol-function (x)
1381   (js!selfcall
1382     "var symbol = " x ";" *newline*
1383     "var func = symbol.fvalue;" *newline*
1384     "if (func === undefined) throw \"Function `\" + xstring(symbol.name) + \"' is undefined.\";" *newline*
1385     "return func;" *newline*))
1386
1387 (define-builtin symbol-plist (x)
1388   (code "((" x ").plist || " (ls-compile nil) ")"))
1389
1390 (define-builtin lambda-code (x)
1391   (code "make_lisp_string((" x ").toString())"))
1392
1393 (define-builtin eq (x y)
1394   (js!bool (code "(" x " === " y ")")))
1395
1396 (define-builtin char-code (x)
1397   (type-check (("x" "string" x))
1398     "x.charCodeAt(0)"))
1399
1400 (define-builtin code-char (x)
1401   (type-check (("x" "number" x))
1402     "String.fromCharCode(x)"))
1403
1404 (define-builtin characterp (x)
1405   (js!bool
1406    (js!selfcall
1407      "var x = " x ";" *newline*
1408      "return (typeof(" x ") == \"string\") && x.length == 1;")))
1409
1410 (define-builtin char-to-string (x)
1411   (js!selfcall
1412     "var r = [" x "];" *newline*
1413     "r.type = 'character';"
1414     "return r"))
1415
1416 (define-builtin char-upcase (x)
1417   (code x ".toUpperCase()"))
1418
1419 (define-builtin char-downcase (x)
1420   (code x ".toLowerCase()"))
1421
1422 (define-builtin stringp (x)
1423   (js!bool
1424    (js!selfcall
1425      "var x = " x ";" *newline*
1426      "return typeof(x) == 'object' && 'length' in x && x.type == 'character';")))
1427
1428 (define-builtin string-upcase (x)
1429   (code "make_lisp_string(xstring(" x ").toUpperCase())"))
1430
1431 (define-builtin string-length (x)
1432   (code x ".length"))
1433
1434 (define-raw-builtin slice (vector a &optional b)
1435   (js!selfcall
1436     "var vector = " (ls-compile vector) ";" *newline*
1437     "var a = " (ls-compile a) ";" *newline*
1438     "var b;" *newline*
1439     (when b (code "b = " (ls-compile b) ";" *newline*))
1440     "return vector.slice(a,b);" *newline*))
1441
1442 (define-builtin char (string index)
1443   (code string "[" index "]"))
1444
1445 (define-builtin concat-two (string1 string2)
1446   (js!selfcall
1447     "var r = " string1 ".concat(" string2 ");" *newline*
1448     "r.type = 'character';"
1449     "return r;" *newline*))
1450
1451 (define-raw-builtin funcall (func &rest args)
1452   (js!selfcall
1453     "var f = " (ls-compile func) ";" *newline*
1454     "return (typeof f === 'function'? f: f.fvalue)("
1455     (join (list* (if *multiple-value-p* "values" "pv")
1456                  (integer-to-string (length args))
1457                  (mapcar #'ls-compile args))
1458           ", ")
1459     ")"))
1460
1461 (define-raw-builtin apply (func &rest args)
1462   (if (null args)
1463       (code "(" (ls-compile func) ")()")
1464       (let ((args (butlast args))
1465             (last (car (last args))))
1466         (js!selfcall
1467           "var f = " (ls-compile func) ";" *newline*
1468           "var args = [" (join (list* (if *multiple-value-p* "values" "pv")
1469                                       (integer-to-string (length args))
1470                                       (mapcar #'ls-compile args))
1471                                ", ")
1472           "];" *newline*
1473           "var tail = (" (ls-compile last) ");" *newline*
1474           "while (tail != " (ls-compile nil) "){" *newline*
1475           "    args.push(tail.car);" *newline*
1476           "    args[1] += 1;" *newline*
1477           "    tail = tail.cdr;" *newline*
1478           "}" *newline*
1479           "return (typeof f === 'function'? f : f.fvalue).apply(this, args);" *newline*))))
1480
1481 (define-builtin js-eval (string)
1482   (if *multiple-value-p*
1483       (js!selfcall
1484         "var v = globalEval(xstring(" string "));" *newline*
1485         "return values.apply(this, forcemv(v));" *newline*)
1486       (code "globalEval(xstring(" string "))")))
1487
1488 (define-builtin %throw (string)
1489   (js!selfcall "throw " string ";" *newline*))
1490
1491 (define-builtin new () "{}")
1492
1493 (define-builtin objectp (x)
1494   (js!bool (code "(typeof (" x ") === 'object')")))
1495
1496 (define-builtin oget (object key)
1497   (js!selfcall
1498     "var tmp = " "(" object ")[xstring(" key ")];" *newline*
1499     "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))
1500
1501 (define-builtin oset (object key value)
1502   (code "((" object ")[xstring(" key ")] = " value ")"))
1503
1504 (define-builtin in (key object)
1505   (js!bool (code "(xstring(" key ") in (" object "))")))
1506
1507 (define-builtin functionp (x)
1508   (js!bool (code "(typeof " x " == 'function')")))
1509
1510 (define-builtin write-string (x)
1511   (code "lisp.write(" x ")"))
1512
1513 (define-builtin make-array (n)
1514   (js!selfcall
1515     "var r = [];" *newline*
1516     "for (var i = 0; i < " n "; i++)" *newline*
1517     (indent "r.push(" (ls-compile nil) ");" *newline*)
1518     "return r;" *newline*))
1519
1520 (define-builtin arrayp (x)
1521   (js!bool
1522    (js!selfcall
1523      "var x = " x ";" *newline*
1524      "return typeof x === 'object' && 'length' in x;")))
1525
1526 (define-builtin aref (array n)
1527   (js!selfcall
1528     "var x = " "(" array ")[" n "];" *newline*
1529     "if (x === undefined) throw 'Out of range';" *newline*
1530     "return x;" *newline*))
1531
1532 (define-builtin aset (array n value)
1533   (js!selfcall
1534     "var x = " array ";" *newline*
1535     "var i = " n ";" *newline*
1536     "if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
1537     "return x[i] = " value ";" *newline*))
1538
1539 (define-builtin get-internal-real-time ()
1540   "(new Date()).getTime()")
1541
1542 (define-builtin values-array (array)
1543   (if *multiple-value-p*
1544       (code "values.apply(this, " array ")")
1545       (code "pv.apply(this, " array ")")))
1546
1547 (define-raw-builtin values (&rest args)
1548   (if *multiple-value-p*
1549       (code "values(" (join (mapcar #'ls-compile args) ", ") ")")
1550       (code "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
1551
1552
1553 ;;; Javascript FFI
1554
1555 (define-compilation %js-vref (var)
1556   (code "js_to_lisp(" var ")"))
1557
1558 (define-compilation %js-vset (var val)
1559   (code "(" var " = lisp_to_js(" (ls-compile val) "))"))
1560
1561 (define-setf-expander %js-vref (var)
1562   (let ((new-value (gensym)))
1563     (unless (stringp var)
1564       (error "`~S' is not a string." var))
1565     (values nil
1566             (list var)
1567             (list new-value)
1568             `(%js-vset ,var ,new-value)
1569             `(%js-vref ,var))))
1570
1571
1572 #+common-lisp
1573 (defvar *macroexpander-cache*
1574   (make-hash-table :test #'eq))
1575
1576 (defun !macro-function (symbol)
1577   (unless (symbolp symbol)
1578     (error "`~S' is not a symbol." symbol))
1579   (let ((b (lookup-in-lexenv symbol *environment* 'function)))
1580     (if (and b (eq (binding-type b) 'macro))
1581         (let ((expander (binding-value b)))
1582           (cond
1583             #+common-lisp
1584             ((gethash b *macroexpander-cache*)
1585              (setq expander (gethash b *macroexpander-cache*)))
1586             ((listp expander)
1587              (let ((compiled (eval expander)))
1588                ;; The list representation are useful while
1589                ;; bootstrapping, as we can dump the definition of the
1590                ;; macros easily, but they are slow because we have to
1591                ;; evaluate them and compile them now and again. So, let
1592                ;; us replace the list representation version of the
1593                ;; function with the compiled one.
1594                ;;
1595                #+jscl (setf (binding-value b) compiled)
1596                #+common-lisp (setf (gethash b *macroexpander-cache*) compiled)
1597                (setq expander compiled))))
1598           expander)
1599         nil)))
1600
1601 (defun !macroexpand-1 (form)
1602   (cond
1603     ((symbolp form)
1604      (let ((b (lookup-in-lexenv form *environment* 'variable)))
1605        (if (and b (eq (binding-type b) 'macro))
1606            (values (binding-value b) t)
1607            (values form nil))))
1608     ((and (consp form) (symbolp (car form)))
1609      (let ((macrofun (!macro-function (car form))))
1610        (if macrofun
1611            (values (funcall macrofun (cdr form)) t)
1612            (values form nil))))
1613     (t
1614      (values form nil))))
1615
1616 (defun compile-funcall (function args)
1617   (let* ((values-funcs (if *multiple-value-p* "values" "pv"))
1618          (arglist (concat "(" (join (list* values-funcs
1619                                            (integer-to-string (length args))
1620                                            (mapcar #'ls-compile args)) ", ") ")")))
1621     (unless (or (symbolp function)
1622                 (and (consp function)
1623                      (eq (car function) 'lambda)))
1624       (error "Bad function designator `~S'" function))
1625     (cond
1626       ((translate-function function)
1627        (concat (translate-function function) arglist))
1628       ((and (symbolp function)
1629             #+jscl (eq (symbol-package function) (find-package "COMMON-LISP"))
1630             #+common-lisp t)
1631        (code (ls-compile `',function) ".fvalue" arglist))
1632       (t
1633        (code (ls-compile `#',function) arglist)))))
1634
1635 (defun ls-compile-block (sexps &optional return-last-p)
1636   (if return-last-p
1637       (code (ls-compile-block (butlast sexps))
1638             "return " (ls-compile (car (last sexps)) *multiple-value-p*) ";")
1639       (join-trailing
1640        (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
1641        (concat ";" *newline*))))
1642
1643 (defun ls-compile (sexp &optional multiple-value-p)
1644   (multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp)
1645     (when expandedp
1646       (return-from ls-compile (ls-compile sexp multiple-value-p)))
1647     ;; The expression has been macroexpanded. Now compile it!
1648     (let ((*multiple-value-p* multiple-value-p))
1649       (cond
1650         ((symbolp sexp)
1651          (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
1652            (cond
1653              ((and b (not (member 'special (binding-declarations b))))
1654               (binding-value b))
1655              ((or (keywordp sexp)
1656                   (and b (member 'constant (binding-declarations b))))
1657               (code (ls-compile `',sexp) ".value"))
1658              (t
1659               (ls-compile `(symbol-value ',sexp))))))
1660         ((or (integerp sexp) (floatp sexp) (characterp sexp) (stringp sexp) (arrayp sexp))
1661          (literal sexp))
1662         ((listp sexp)
1663          (let ((name (car sexp))
1664                (args (cdr sexp)))
1665            (cond
1666              ;; Special forms
1667              ((assoc name *compilations*)
1668               (let ((comp (second (assoc name *compilations*))))
1669                 (apply comp args)))
1670              ;; Built-in functions
1671              ((and (assoc name *builtins*)
1672                    (not (claimp name 'function 'notinline)))
1673               (let ((comp (second (assoc name *builtins*))))
1674                 (apply comp args)))
1675              (t
1676               (compile-funcall name args)))))
1677         (t
1678          (error "How should I compile `~S'?" sexp))))))
1679
1680
1681 (defvar *compile-print-toplevels* nil)
1682
1683 (defun truncate-string (string &optional (width 60))
1684   (let ((n (or (position #\newline string)
1685                (min width (length string)))))
1686     (subseq string 0 n)))
1687
1688 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
1689   (let ((*toplevel-compilations* nil))
1690     (cond
1691       ((and (consp sexp) (eq (car sexp) 'progn))
1692        (let ((subs (mapcar (lambda (s)
1693                              (ls-compile-toplevel s t))
1694                            (cdr sexp))))
1695          (join (remove-if #'null-or-empty-p subs))))
1696       (t
1697        (when *compile-print-toplevels*
1698          (let ((form-string (prin1-to-string sexp)))
1699            (format t "Compiling ~a..." (truncate-string form-string))))
1700        (let ((code (ls-compile sexp multiple-value-p)))
1701          (code (join-trailing (get-toplevel-compilations)
1702                               (code ";" *newline*))
1703                (when code
1704                  (code code ";" *newline*))))))))