src/compiler.lisp

   1 ;;; compiler.lisp ---
   2
   3 ;; Copyright (C) 2012, 2013 David Vazquez
   4 ;; Copyright (C) 2012 Raimon Grau
   5
   6 ;; This program 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 ;; This program 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 this program.  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                  ((stringp arg) arg)
  32                  (t (error "Unknown argument."))))
  33              args))
  34
  35 ;;; Wrap X with a Javascript code to convert the result from
  36 ;;; Javascript generalized booleans to T or NIL.
  37 (defun js!bool (x)
  38   (code "(" x "?" (ls-compile t) ": " (ls-compile nil) ")"))
  39
  40 ;;; Concatenate the arguments and wrap them with a self-calling
  41 ;;; Javascript anonymous function. It is used to make some Javascript
  42 ;;; statements valid expressions and provide a private scope as well.
  43 ;;; It could be defined as function, but we could do some
  44 ;;; preprocessing in the future.
  45 (defmacro js!selfcall (&body body)
  46   `(code "(function(){" *newline* (indent ,@body) "})()"))
  47
  48 ;;; Like CODE, but prefix each line with four spaces. Two versions
  49 ;;; of this function are available, because the Ecmalisp version is
  50 ;;; very slow and bootstraping was annoying.
  51
  52 #+ecmalisp
  53 (defun indent (&rest string)
  54   (let ((input (apply #'code string)))
  55     (let ((output "")
  56           (index 0)
  57           (size (length input)))
  58       (when (plusp (length input)) (concatf output "    "))
  59       (while (< index size)
  60         (let ((str
  61                (if (and (char= (char input index) #\newline)
  62                         (< index (1- size))
  63                         (not (char= (char input (1+ index)) #\newline)))
  64                    (concat (string #\newline) "    ")
  65                    (string (char input index)))))
  66           (concatf output str))
  67         (incf index))
  68       output)))
  69
  70 #+common-lisp
  71 (defun indent (&rest string)
  72   (with-output-to-string (*standard-output*)
  73     (with-input-from-string (input (apply #'code string))
  74       (loop
  75          for line = (read-line input nil)
  76          while line
  77          do (write-string "    ")
  78          do (write-line line)))))
  79
  80
  81 ;;; A Form can return a multiple values object calling VALUES, like
  82 ;;; values(arg1, arg2, ...). It will work in any context, as well as
  83 ;;; returning an individual object. However, if the special variable
  84 ;;; `*multiple-value-p*' is NIL, is granted that only the primary
  85 ;;; value will be used, so we can optimize to avoid the VALUES
  86 ;;; function call.
  87 (defvar *multiple-value-p* nil)
  88
  89 ;; A very simple defstruct built on lists. It supports just slot with
  90 ;; an optional default initform, and it will create a constructor,
  91 ;; predicate and accessors for you.
  92 (defmacro def!struct (name &rest slots)
  93   (unless (symbolp name)
  94     (error "It is not a full defstruct implementation."))
  95   (let* ((name-string (symbol-name name))
  96          (slot-descriptions
  97           (mapcar (lambda (sd)
  98                     (cond
  99                       ((symbolp sd)
 100                        (list sd))
 101                       ((and (listp sd) (car sd) (cddr sd))
 102                        sd)
 103                       (t
 104                        (error "Bad slot accessor."))))
 105                   slots))
 106          (predicate (intern (concat name-string "-P"))))
 107     `(progn
 108        ;; Constructor
 109        (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
 110          (list ',name ,@(mapcar #'car slot-descriptions)))
 111        ;; Predicate
 112        (defun ,predicate (x)
 113          (and (consp x) (eq (car x) ',name)))
 114        ;; Copier
 115        (defun ,(intern (concat "COPY-" name-string)) (x)
 116          (copy-list x))
 117        ;; Slot accessors
 118        ,@(with-collect
 119           (let ((index 1))
 120             (dolist (slot slot-descriptions)
 121               (let* ((name (car slot))
 122                      (accessor-name (intern (concat name-string "-" (string name)))))
 123                 (collect
 124                     `(defun ,accessor-name (x)
 125                        (unless (,predicate x)
 126                          (error ,(concat "The object is not a type " name-string)))
 127                        (nth ,index x)))
 128                 ;; TODO: Implement this with a higher level
 129                 ;; abstraction like defsetf or (defun (setf ..))
 130                 (collect
 131                     `(define-setf-expander ,accessor-name (x)
 132                        (let ((object (gensym))
 133                              (new-value (gensym)))
 134                          (values (list object)
 135                                  (list x)
 136                                  (list new-value)
 137                                  `(progn
 138                                     (rplaca (nthcdr ,',index ,object) ,new-value)
 139                                     ,new-value)
 140                                  `(,',accessor-name ,object)))))
 141                 (incf index)))))
 142        ',name)))
 143
 144
 145 ;;; Environment
 146
 147 (def!struct binding
 148   name
 149   type
 150   value
 151   declarations)
 152
 153 (def!struct lexenv
 154   variable
 155   function
 156   block
 157   gotag)
 158
 159 (defun lookup-in-lexenv (name lexenv namespace)
 160   (find name (ecase namespace
 161                 (variable (lexenv-variable lexenv))
 162                 (function (lexenv-function lexenv))
 163                 (block    (lexenv-block    lexenv))
 164                 (gotag    (lexenv-gotag    lexenv)))
 165         :key #'binding-name))
 166
 167 (defun push-to-lexenv (binding lexenv namespace)
 168   (ecase namespace
 169     (variable (push binding (lexenv-variable lexenv)))
 170     (function (push binding (lexenv-function lexenv)))
 171     (block    (push binding (lexenv-block    lexenv)))
 172     (gotag    (push binding (lexenv-gotag    lexenv)))))
 173
 174 (defun extend-lexenv (bindings lexenv namespace)
 175   (let ((env (copy-lexenv lexenv)))
 176     (dolist (binding (reverse bindings) env)
 177       (push-to-lexenv binding env namespace))))
 178
 179
 180 (defvar *environment* (make-lexenv))
 181
 182 (defvar *variable-counter* 0)
 183
 184 (defun gvarname (symbol)
 185   (code "v" (incf *variable-counter*)))
 186
 187 (defun translate-variable (symbol)
 188   (awhen (lookup-in-lexenv symbol *environment* 'variable)
 189     (binding-value it)))
 190
 191 (defun extend-local-env (args)
 192   (let ((new (copy-lexenv *environment*)))
 193     (dolist (symbol args new)
 194       (let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol))))
 195         (push-to-lexenv b new 'variable)))))
 196
 197 ;;; Toplevel compilations
 198 (defvar *toplevel-compilations* nil)
 199
 200 (defun toplevel-compilation (string)
 201   (push string *toplevel-compilations*))
 202
 203 (defun null-or-empty-p (x)
 204   (zerop (length x)))
 205
 206 (defun get-toplevel-compilations ()
 207   (reverse (remove-if #'null-or-empty-p *toplevel-compilations*)))
 208
 209 (defun %compile-defmacro (name lambda)
 210   (toplevel-compilation (ls-compile `',name))
 211   (let ((binding (make-binding :name name :type 'macro :value lambda)))
 212     (push-to-lexenv binding  *environment* 'function))
 213   name)
 214
 215 (defun global-binding (name type namespace)
 216   (or (lookup-in-lexenv name *environment* namespace)
 217       (let ((b (make-binding :name name :type type :value nil)))
 218         (push-to-lexenv b *environment* namespace)
 219         b)))
 220
 221 (defun claimp (symbol namespace claim)
 222   (let ((b (lookup-in-lexenv symbol *environment* namespace)))
 223     (and b (member claim (binding-declarations b)))))
 224
 225 (defun !proclaim (decl)
 226   (case (car decl)
 227     (special
 228      (dolist (name (cdr decl))
 229        (let ((b (global-binding name 'variable 'variable)))
 230          (push 'special (binding-declarations b)))))
 231     (notinline
 232      (dolist (name (cdr decl))
 233        (let ((b (global-binding name 'function 'function)))
 234          (push 'notinline (binding-declarations b)))))
 235     (constant
 236      (dolist (name (cdr decl))
 237        (let ((b (global-binding name 'variable 'variable)))
 238          (push 'constant (binding-declarations b)))))))
 239
 240 #+ecmalisp
 241 (fset 'proclaim #'!proclaim)
 242
 243 (defun %define-symbol-macro (name expansion)
 244   (let ((b (make-binding :name name :type 'macro :value expansion)))
 245     (push-to-lexenv b *environment* 'variable)
 246     name))
 247
 248 #+ecmalisp
 249 (defmacro define-symbol-macro (name expansion)
 250   `(%define-symbol-macro ',name ',expansion))
 251
 252
 253 ;;; Special forms
 254
 255 (defvar *compilations* nil)
 256
 257 (defmacro define-compilation (name args &body body)
 258   ;; Creates a new primitive `name' with parameters args and
 259   ;; @body. The body can access to the local environment through the
 260   ;; variable *ENVIRONMENT*.
 261   `(push (list ',name (lambda ,args (block ,name ,@body)))
 262          *compilations*))
 263
 264 (define-compilation if (condition true false)
 265   (code "(" (ls-compile condition) " !== " (ls-compile nil)
 266         " ? " (ls-compile true *multiple-value-p*)
 267         " : " (ls-compile false *multiple-value-p*)
 268         ")"))
 269
 270 (defvar *ll-keywords* '(&optional &rest &key))
 271
 272 (defun list-until-keyword (list)
 273   (if (or (null list) (member (car list) *ll-keywords*))
 274       nil
 275       (cons (car list) (list-until-keyword (cdr list)))))
 276
 277 (defun ll-section (keyword ll)
 278   (list-until-keyword (cdr (member keyword ll))))
 279
 280 (defun ll-required-arguments (ll)
 281   (list-until-keyword ll))
 282
 283 (defun ll-optional-arguments-canonical (ll)
 284   (mapcar #'ensure-list (ll-section '&optional ll)))
 285
 286 (defun ll-optional-arguments (ll)
 287   (mapcar #'car (ll-optional-arguments-canonical ll)))
 288
 289 (defun ll-rest-argument (ll)
 290   (let ((rest (ll-section '&rest ll)))
 291     (when (cdr rest)
 292       (error "Bad lambda-list"))
 293     (car rest)))
 294
 295 (defun ll-keyword-arguments-canonical (ll)
 296   (flet ((canonicalize (keyarg)
 297            ;; Build a canonical keyword argument descriptor, filling
 298            ;; the optional fields. The result is a list of the form
 299            ;; ((keyword-name var) init-form).
 300            (let ((arg (ensure-list keyarg)))
 301              (cons (if (listp (car arg))
 302                        (car arg)
 303                        (list (intern (symbol-name (car arg)) "KEYWORD") (car arg)))
 304                    (cdr arg)))))
 305     (mapcar #'canonicalize (ll-section '&key ll))))
 306
 307 (defun ll-keyword-arguments (ll)
 308   (mapcar (lambda (keyarg) (second (first keyarg)))
 309           (ll-keyword-arguments-canonical ll)))
 310
 311 (defun ll-svars (lambda-list)
 312   (let ((args
 313          (append
 314           (ll-keyword-arguments-canonical lambda-list)
 315           (ll-optional-arguments-canonical lambda-list))))
 316     (remove nil (mapcar #'third args))))
 317
 318 (defun lambda-docstring-wrapper (docstring &rest strs)
 319   (if docstring
 320       (js!selfcall
 321         "var func = " (join strs) ";" *newline*
 322         "func.docstring = '" docstring "';" *newline*
 323         "return func;" *newline*)
 324       (apply #'code strs)))
 325
 326 (defun lambda-check-argument-count
 327     (n-required-arguments n-optional-arguments rest-p)
 328   ;; Note: Remember that we assume that the number of arguments of a
 329   ;; call is at least 1 (the values argument).
 330   (let ((min (1+ n-required-arguments))
 331         (max (if rest-p 'n/a (+ 1 n-required-arguments n-optional-arguments))))
 332     (block nil
 333       ;; Special case: a positive exact number of arguments.
 334       (when (and (< 1 min) (eql min max))
 335         (return (code "checkArgs(arguments, " min ");" *newline*)))
 336       ;; General case:
 337       (code
 338        (when (< 1 min)
 339          (code "checkArgsAtLeast(arguments, " min ");" *newline*))
 340        (when (numberp max)
 341          (code "checkArgsAtMost(arguments, " max ");" *newline*))))))
 342
 343 (defun compile-lambda-optional (ll)
 344   (let* ((optional-arguments (ll-optional-arguments-canonical ll))
 345          (n-required-arguments (length (ll-required-arguments ll)))
 346          (n-optional-arguments (length optional-arguments)))
 347     (when optional-arguments
 348       (code (mapconcat (lambda (arg)
 349                          (code "var " (translate-variable (first arg)) "; " *newline*
 350                                (when (third arg)
 351                                  (code "var " (translate-variable (third arg))
 352                                        " = " (ls-compile t)
 353                                        "; " *newline*))))
 354                        optional-arguments)
 355             "switch(arguments.length-1){" *newline*
 356             (let ((cases nil)
 357                   (idx 0))
 358               (progn
 359                 (while (< idx n-optional-arguments)
 360                   (let ((arg (nth idx optional-arguments)))
 361                     (push (code "case " (+ idx n-required-arguments) ":" *newline*
 362                                 (indent (translate-variable (car arg))
 363                                         "="
 364                                         (ls-compile (cadr arg)) ";" *newline*)
 365                                 (when (third arg)
 366                                   (indent (translate-variable (third arg))
 367                                           "="
 368                                           (ls-compile nil)
 369                                           ";" *newline*)))
 370                           cases)
 371                     (incf idx)))
 372                 (push (code "default: break;" *newline*) cases)
 373                 (join (reverse cases))))
 374             "}" *newline*))))
 375
 376 (defun compile-lambda-rest (ll)
 377   (let ((n-required-arguments (length (ll-required-arguments ll)))
 378         (n-optional-arguments (length (ll-optional-arguments ll)))
 379         (rest-argument (ll-rest-argument ll)))
 380     (when rest-argument
 381       (let ((js!rest (translate-variable rest-argument)))
 382         (code "var " js!rest "= " (ls-compile nil) ";" *newline*
 383               "for (var i = arguments.length-1; i>="
 384               (+ 1 n-required-arguments n-optional-arguments)
 385               "; i--)" *newline*
 386               (indent js!rest " = {car: arguments[i], cdr: ") js!rest "};"
 387               *newline*)))))
 388
 389 (defun compile-lambda-parse-keywords (ll)
 390   (let ((n-required-arguments
 391          (length (ll-required-arguments ll)))
 392         (n-optional-arguments
 393          (length (ll-optional-arguments ll)))
 394         (keyword-arguments
 395          (ll-keyword-arguments-canonical ll)))
 396     (code
 397      ;; Declare variables
 398      (mapconcat (lambda (arg)
 399                   (let ((var (second (car arg))))
 400                     (code "var " (translate-variable var) "; " *newline*
 401                           (when (third arg)
 402                             (code "var " (translate-variable (third arg))
 403                                   " = " (ls-compile nil)
 404                                   ";" *newline*)))))
 405                 keyword-arguments)
 406      ;; Parse keywords
 407      (flet ((parse-keyword (keyarg)
 408               ;; ((keyword-name var) init-form)
 409               (code "for (i=" (+ 1 n-required-arguments n-optional-arguments)
 410                     "; i<arguments.length; i+=2){" *newline*
 411                     (indent
 412                      "if (arguments[i] === " (ls-compile (caar keyarg)) "){" *newline*
 413                      (indent (translate-variable (cadr (car keyarg)))
 414                              " = arguments[i+1];"
 415                              *newline*
 416                              (let ((svar (third keyarg)))
 417                                (when svar
 418                                  (code (translate-variable svar) " = " (ls-compile t) ";" *newline*)))
 419                              "break;" *newline*)
 420                      "}" *newline*)
 421                     "}" *newline*
 422                     ;; Default value
 423                     "if (i == arguments.length){" *newline*
 424                     (indent (translate-variable (cadr (car keyarg))) " = " (ls-compile (cadr keyarg)) ";" *newline*)
 425                     "}" *newline*)))
 426        (when keyword-arguments
 427          (code "var i;" *newline*
 428                (mapconcat #'parse-keyword keyword-arguments))))
 429      ;; Check for unknown keywords
 430      (when keyword-arguments
 431        (code "for (i=" (+ 1 n-required-arguments n-optional-arguments)
 432              "; i<arguments.length; i+=2){" *newline*
 433              (indent "if ("
 434                      (join (mapcar (lambda (x)
 435                                      (concat "arguments[i] !== " (ls-compile (caar x))))
 436                                    keyword-arguments)
 437                            " && ")
 438                      ")" *newline*
 439                      (indent
 440                       "throw 'Unknown keyword argument ' + arguments[i].name;" *newline*))
 441              "}" *newline*)))))
 442
 443 (defun compile-lambda (ll body)
 444   (let ((required-arguments (ll-required-arguments ll))
 445         (optional-arguments (ll-optional-arguments ll))
 446         (keyword-arguments  (ll-keyword-arguments  ll))
 447         (rest-argument      (ll-rest-argument      ll))
 448         documentation)
 449     ;; Get the documentation string for the lambda function
 450     (when (and (stringp (car body))
 451                (not (null (cdr body))))
 452       (setq documentation (car body))
 453       (setq body (cdr body)))
 454     (let ((n-required-arguments (length required-arguments))
 455           (n-optional-arguments (length optional-arguments))
 456           (*environment* (extend-local-env
 457                           (append (ensure-list rest-argument)
 458                                   required-arguments
 459                                   optional-arguments
 460                                   keyword-arguments
 461                                   (ll-svars ll)))))
 462       (lambda-docstring-wrapper
 463        documentation
 464        "(function ("
 465        (join (cons "values"
 466                    (mapcar #'translate-variable
 467                            (append required-arguments optional-arguments)))
 468              ",")
 469        "){" *newline*
 470        (indent
 471         ;; Check number of arguments
 472         (lambda-check-argument-count n-required-arguments
 473                                      n-optional-arguments
 474                                      (or rest-argument keyword-arguments))
 475         (compile-lambda-optional ll)
 476         (compile-lambda-rest ll)
 477         (compile-lambda-parse-keywords ll)
 478         (let ((*multiple-value-p* t))
 479           (ls-compile-block body t)))
 480        "})"))))
 481
 482
 483 (defun setq-pair (var val)
 484   (let ((b (lookup-in-lexenv var *environment* 'variable)))
 485     (cond
 486       ((and b
 487             (eq (binding-type b) 'variable)
 488             (not (member 'special (binding-declarations b)))
 489             (not (member 'constant (binding-declarations b))))
 490        (code (binding-value b) " = " (ls-compile val)))
 491       ((and b (eq (binding-type b) 'macro))
 492        (ls-compile `(setf ,var ,val)))
 493       (t
 494        (ls-compile `(set ',var ,val))))))
 495
 496
 497 (define-compilation setq (&rest pairs)
 498   (let ((result ""))
 499     (while t
 500       (cond
 501         ((null pairs) (return))
 502         ((null (cdr pairs))
 503          (error "Odd paris in SETQ"))
 504         (t
 505          (concatf result
 506            (concat (setq-pair (car pairs) (cadr pairs))
 507                    (if (null (cddr pairs)) "" ", ")))
 508          (setq pairs (cddr pairs)))))
 509     (code "(" result ")")))
 510
 511
 512 ;;; Literals
 513 (defun escape-string (string)
 514   (let ((output "")
 515         (index 0)
 516         (size (length string)))
 517     (while (< index size)
 518       (let ((ch (char string index)))
 519         (when (or (char= ch #\") (char= ch #\\))
 520           (setq output (concat output "\\")))
 521         (when (or (char= ch #\newline))
 522           (setq output (concat output "\\"))
 523           (setq ch #\n))
 524         (setq output (concat output (string ch))))
 525       (incf index))
 526     output))
 527
 528
 529 (defvar *literal-symbols* nil)
 530 (defvar *literal-counter* 0)
 531
 532 (defun genlit ()
 533   (code "l" (incf *literal-counter*)))
 534
 535 (defun literal (sexp &optional recursive)
 536   (cond
 537     ((integerp sexp) (integer-to-string sexp))
 538     ((stringp sexp) (code "\"" (escape-string sexp) "\""))
 539     ((symbolp sexp)
 540      (or (cdr (assoc sexp *literal-symbols*))
 541          (let ((v (genlit))
 542                (s #+common-lisp
 543                  (let ((package (symbol-package sexp)))
 544                    (if (eq package (find-package "KEYWORD"))
 545                        (code "{name: \"" (escape-string (symbol-name sexp))
 546                              "\", 'package': '" (package-name package) "'}")
 547                        (code "{name: \"" (escape-string (symbol-name sexp)) "\"}")))
 548                  #+ecmalisp
 549                  (let ((package (symbol-package sexp)))
 550                    (if (null package)
 551                        (code "{name: \"" (escape-string (symbol-name sexp)) "\"}")
 552                        (ls-compile `(intern ,(symbol-name sexp) ,(package-name package)))))))
 553            (push (cons sexp v) *literal-symbols*)
 554            (toplevel-compilation (code "var " v " = " s))
 555            v)))
 556     ((consp sexp)
 557      (let* ((head (butlast sexp))
 558             (tail (last sexp))
 559             (c (code "QIList("
 560                      (join-trailing (mapcar (lambda (x) (literal x t)) head) ",")
 561                      (literal (car tail) t)
 562                      ","
 563                      (literal (cdr tail) t)
 564                      ")")))
 565        (if recursive
 566            c
 567            (let ((v (genlit)))
 568              (toplevel-compilation (code "var " v " = " c))
 569              v))))
 570     ((arrayp sexp)
 571      (let ((elements (vector-to-list sexp)))
 572        (let ((c (concat "[" (join (mapcar #'literal elements) ", ") "]")))
 573          (if recursive
 574              c
 575              (let ((v (genlit)))
 576                (toplevel-compilation (code "var " v " = " c))
 577                v)))))))
 578
 579 (define-compilation quote (sexp)
 580   (literal sexp))
 581
 582 (define-compilation %while (pred &rest body)
 583   (js!selfcall
 584     "while(" (ls-compile pred) " !== " (ls-compile nil) "){" *newline*
 585     (indent (ls-compile-block body))
 586     "}"
 587     "return " (ls-compile nil) ";" *newline*))
 588
 589 (define-compilation function (x)
 590   (cond
 591     ((and (listp x) (eq (car x) 'lambda))
 592      (compile-lambda (cadr x) (cddr x)))
 593     ((symbolp x)
 594      (let ((b (lookup-in-lexenv x *environment* 'function)))
 595        (if b
 596            (binding-value b)
 597            (ls-compile `(symbol-function ',x)))))))
 598
 599
 600 (defun make-function-binding (fname)
 601   (make-binding :name fname :type 'function :value (gvarname fname)))
 602
 603 (defun compile-function-definition (list)
 604   (compile-lambda (car list) (cdr list)))
 605
 606 (defun translate-function (name)
 607   (let ((b (lookup-in-lexenv name *environment* 'function)))
 608     (and b (binding-value b))))
 609
 610 (define-compilation flet (definitions &rest body)
 611   (let* ((fnames (mapcar #'car definitions))
 612          (fbody  (mapcar #'cdr definitions))
 613          (cfuncs (mapcar #'compile-function-definition fbody))
 614          (*environment*
 615           (extend-lexenv (mapcar #'make-function-binding fnames)
 616                          *environment*
 617                          'function)))
 618     (code "(function("
 619           (join (mapcar #'translate-function fnames) ",")
 620           "){" *newline*
 621           (let ((body (ls-compile-block body t)))
 622             (indent body))
 623           "})(" (join cfuncs ",") ")")))
 624
 625 (define-compilation labels (definitions &rest body)
 626   (let* ((fnames (mapcar #'car definitions))
 627          (*environment*
 628           (extend-lexenv (mapcar #'make-function-binding fnames)
 629                          *environment*
 630                          'function)))
 631     (js!selfcall
 632       (mapconcat (lambda (func)
 633                    (code "var " (translate-function (car func))
 634                          " = " (compile-lambda (cadr func) (cddr func))
 635                          ";" *newline*))
 636                  definitions)
 637       (ls-compile-block body t))))
 638
 639
 640 (defvar *compiling-file* nil)
 641 (define-compilation eval-when-compile (&rest body)
 642   (if *compiling-file*
 643       (progn
 644         (eval (cons 'progn body))
 645         nil)
 646       (ls-compile `(progn ,@body))))
 647
 648 (defmacro define-transformation (name args form)
 649   `(define-compilation ,name ,args
 650      (ls-compile ,form)))
 651
 652 (define-compilation progn (&rest body)
 653   (if (null (cdr body))
 654       (ls-compile (car body) *multiple-value-p*)
 655       (js!selfcall (ls-compile-block body t))))
 656
 657 (defun special-variable-p (x)
 658   (and (claimp x 'variable 'special) t))
 659
 660 ;;; Wrap CODE to restore the symbol values of the dynamic
 661 ;;; bindings. BINDINGS is a list of pairs of the form
 662 ;;; (SYMBOL . PLACE),  where PLACE is a Javascript variable
 663 ;;; name to initialize the symbol value and where to stored
 664 ;;; the old value.
 665 (defun let-binding-wrapper (bindings body)
 666   (when (null bindings)
 667     (return-from let-binding-wrapper body))
 668   (code
 669    "try {" *newline*
 670    (indent "var tmp;" *newline*
 671            (mapconcat
 672             (lambda (b)
 673               (let ((s (ls-compile `(quote ,(car b)))))
 674                 (code "tmp = " s ".value;" *newline*
 675                       s ".value = " (cdr b) ";" *newline*
 676                       (cdr b) " = tmp;" *newline*)))
 677             bindings)
 678            body *newline*)
 679    "}" *newline*
 680    "finally {"  *newline*
 681    (indent
 682     (mapconcat (lambda (b)
 683                  (let ((s (ls-compile `(quote ,(car b)))))
 684                    (code s ".value" " = " (cdr b) ";" *newline*)))
 685                bindings))
 686    "}" *newline*))
 687
 688 (define-compilation let (bindings &rest body)
 689   (let* ((bindings (mapcar #'ensure-list bindings))
 690          (variables (mapcar #'first bindings))
 691          (cvalues (mapcar #'ls-compile (mapcar #'second bindings)))
 692          (*environment* (extend-local-env (remove-if #'special-variable-p variables)))
 693          (dynamic-bindings))
 694     (code "(function("
 695           (join (mapcar (lambda (x)
 696                           (if (special-variable-p x)
 697                               (let ((v (gvarname x)))
 698                                 (push (cons x v) dynamic-bindings)
 699                                 v)
 700                               (translate-variable x)))
 701                         variables)
 702                 ",")
 703           "){" *newline*
 704           (let ((body (ls-compile-block body t)))
 705             (indent (let-binding-wrapper dynamic-bindings body)))
 706           "})(" (join cvalues ",") ")")))
 707
 708
 709 ;;; Return the code to initialize BINDING, and push it extending the
 710 ;;; current lexical environment if the variable is not special.
 711 (defun let*-initialize-value (binding)
 712   (let ((var (first binding))
 713         (value (second binding)))
 714     (if (special-variable-p var)
 715         (code (ls-compile `(setq ,var ,value)) ";" *newline*)
 716         (let* ((v (gvarname var))
 717                (b (make-binding :name var :type 'variable :value v)))
 718           (prog1 (code "var " v " = " (ls-compile value) ";" *newline*)
 719             (push-to-lexenv b *environment* 'variable))))))
 720
 721 ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It
 722 ;;; DOES NOT generate code to initialize the value of the symbols,
 723 ;;; unlike let-binding-wrapper.
 724 (defun let*-binding-wrapper (symbols body)
 725   (when (null symbols)
 726     (return-from let*-binding-wrapper body))
 727   (let ((store (mapcar (lambda (s) (cons s (gvarname s)))
 728                        (remove-if-not #'special-variable-p symbols))))
 729     (code
 730      "try {" *newline*
 731      (indent
 732       (mapconcat (lambda (b)
 733                    (let ((s (ls-compile `(quote ,(car b)))))
 734                      (code "var " (cdr b) " = " s ".value;" *newline*)))
 735                  store)
 736       body)
 737      "}" *newline*
 738      "finally {" *newline*
 739      (indent
 740       (mapconcat (lambda (b)
 741                    (let ((s (ls-compile `(quote ,(car b)))))
 742                      (code s ".value" " = " (cdr b) ";" *newline*)))
 743                  store))
 744      "}" *newline*)))
 745
 746 (define-compilation let* (bindings &rest body)
 747   (let ((bindings (mapcar #'ensure-list bindings))
 748         (*environment* (copy-lexenv *environment*)))
 749     (js!selfcall
 750       (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
 751             (body (concat (mapconcat #'let*-initialize-value bindings)
 752                           (ls-compile-block body t))))
 753         (let*-binding-wrapper specials body)))))
 754
 755
 756 (defvar *block-counter* 0)
 757
 758 (define-compilation block (name &rest body)
 759   (let* ((tr (incf *block-counter*))
 760          (b (make-binding :name name :type 'block :value tr)))
 761     (when *multiple-value-p*
 762       (push 'multiple-value (binding-declarations b)))
 763     (let* ((*environment* (extend-lexenv (list b) *environment* 'block))
 764            (cbody (ls-compile-block body t)))
 765       (if (member 'used (binding-declarations b))
 766           (js!selfcall
 767             "try {" *newline*
 768             (indent cbody)
 769             "}" *newline*
 770             "catch (cf){" *newline*
 771             "    if (cf.type == 'block' && cf.id == " tr ")" *newline*
 772             (if *multiple-value-p*
 773                 "        return values.apply(this, forcemv(cf.values));"
 774                 "        return cf.values;")
 775             *newline*
 776             "    else" *newline*
 777             "        throw cf;" *newline*
 778             "}" *newline*)
 779           (js!selfcall cbody)))))
 780
 781 (define-compilation return-from (name &optional value)
 782   (let* ((b (lookup-in-lexenv name *environment* 'block))
 783          (multiple-value-p (member 'multiple-value (binding-declarations b))))
 784     (when (null b)
 785       (error (concat "Unknown block `" (symbol-name name) "'.")))
 786     (push 'used (binding-declarations b))
 787     (js!selfcall
 788       (when multiple-value-p (code "var values = mv;" *newline*))
 789       "throw ({"
 790       "type: 'block', "
 791       "id: " (binding-value b) ", "
 792       "values: " (ls-compile value multiple-value-p) ", "
 793       "message: 'Return from unknown block " (symbol-name name) ".'"
 794       "})")))
 795
 796 (define-compilation catch (id &rest body)
 797   (js!selfcall
 798     "var id = " (ls-compile id) ";" *newline*
 799     "try {" *newline*
 800     (indent (ls-compile-block body t)) *newline*
 801     "}" *newline*
 802     "catch (cf){" *newline*
 803     "    if (cf.type == 'catch' && cf.id == id)" *newline*
 804     (if *multiple-value-p*
 805         "        return values.apply(this, forcemv(cf.values));"
 806         "        return pv.apply(this, forcemv(cf.values));")
 807     *newline*
 808     "    else" *newline*
 809     "        throw cf;" *newline*
 810     "}" *newline*))
 811
 812 (define-compilation throw (id value)
 813   (js!selfcall
 814     "var values = mv;" *newline*
 815     "throw ({"
 816     "type: 'catch', "
 817     "id: " (ls-compile id) ", "
 818     "values: " (ls-compile value t) ", "
 819     "message: 'Throw uncatched.'"
 820     "})"))
 821
 822
 823 (defvar *tagbody-counter* 0)
 824 (defvar *go-tag-counter* 0)
 825
 826 (defun go-tag-p (x)
 827   (or (integerp x) (symbolp x)))
 828
 829 (defun declare-tagbody-tags (tbidx body)
 830   (let ((bindings
 831          (mapcar (lambda (label)
 832                    (let ((tagidx (integer-to-string (incf *go-tag-counter*))))
 833                      (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
 834                  (remove-if-not #'go-tag-p body))))
 835     (extend-lexenv bindings *environment* 'gotag)))
 836
 837 (define-compilation tagbody (&rest body)
 838   ;; Ignore the tagbody if it does not contain any go-tag. We do this
 839   ;; because 1) it is easy and 2) many built-in forms expand to a
 840   ;; implicit tagbody, so we save some space.
 841   (unless (some #'go-tag-p body)
 842     (return-from tagbody (ls-compile `(progn ,@body nil))))
 843   ;; The translation assumes the first form in BODY is a label
 844   (unless (go-tag-p (car body))
 845     (push (gensym "START") body))
 846   ;; Tagbody compilation
 847   (let ((tbidx *tagbody-counter*))
 848     (let ((*environment* (declare-tagbody-tags tbidx body))
 849           initag)
 850       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
 851         (setq initag (second (binding-value b))))
 852       (js!selfcall
 853         "var tagbody_" tbidx " = " initag ";" *newline*
 854         "tbloop:" *newline*
 855         "while (true) {" *newline*
 856         (indent "try {" *newline*
 857                 (indent (let ((content ""))
 858                           (code "switch(tagbody_" tbidx "){" *newline*
 859                                 "case " initag ":" *newline*
 860                                 (dolist (form (cdr body) content)
 861                                   (concatf content
 862                                     (if (not (go-tag-p form))
 863                                         (indent (ls-compile form) ";" *newline*)
 864                                         (let ((b (lookup-in-lexenv form *environment* 'gotag)))
 865                                           (code "case " (second (binding-value b)) ":" *newline*)))))
 866                                 "default:" *newline*
 867                                 "    break tbloop;" *newline*
 868                                 "}" *newline*)))
 869                 "}" *newline*
 870                 "catch (jump) {" *newline*
 871                 "    if (jump.type == 'tagbody' && jump.id == " tbidx ")" *newline*
 872                 "        tagbody_" tbidx " = jump.label;" *newline*
 873                 "    else" *newline*
 874                 "        throw(jump);" *newline*
 875                 "}" *newline*)
 876         "}" *newline*
 877         "return " (ls-compile nil) ";" *newline*))))
 878
 879 (define-compilation go (label)
 880   (let ((b (lookup-in-lexenv label *environment* 'gotag))
 881         (n (cond
 882              ((symbolp label) (symbol-name label))
 883              ((integerp label) (integer-to-string label)))))
 884     (when (null b)
 885       (error (concat "Unknown tag `" n "'.")))
 886     (js!selfcall
 887       "throw ({"
 888       "type: 'tagbody', "
 889       "id: " (first (binding-value b)) ", "
 890       "label: " (second (binding-value b)) ", "
 891       "message: 'Attempt to GO to non-existing tag " n "'"
 892       "})" *newline*)))
 893
 894 (define-compilation unwind-protect (form &rest clean-up)
 895   (js!selfcall
 896     "var ret = " (ls-compile nil) ";" *newline*
 897     "try {" *newline*
 898     (indent "ret = " (ls-compile form) ";" *newline*)
 899     "} finally {" *newline*
 900     (indent (ls-compile-block clean-up))
 901     "}" *newline*
 902     "return ret;" *newline*))
 903
 904 (define-compilation multiple-value-call (func-form &rest forms)
 905   (js!selfcall
 906     "var func = " (ls-compile func-form) ";" *newline*
 907     "var args = [" (if *multiple-value-p* "values" "pv") "];" *newline*
 908     "return "
 909     (js!selfcall
 910       "var values = mv;" *newline*
 911       "var vs;" *newline*
 912       (mapconcat (lambda (form)
 913                    (code "vs = " (ls-compile form t) ";" *newline*
 914                          "if (typeof vs === 'object' && 'multiple-value' in vs)" *newline*
 915                          (indent "args = args.concat(vs);" *newline*)
 916                          "else" *newline*
 917                          (indent "args.push(vs);" *newline*)))
 918                  forms)
 919       "return func.apply(window, args);" *newline*) ";" *newline*))
 920
 921 (define-compilation multiple-value-prog1 (first-form &rest forms)
 922   (js!selfcall
 923     "var args = " (ls-compile first-form *multiple-value-p*) ";" *newline*
 924     (ls-compile-block forms)
 925     "return args;" *newline*))
 926
 927
 928 ;;; Javascript FFI
 929
 930 (define-compilation %js-vref (var) var)
 931
 932 (define-compilation %js-vset (var val)
 933   (code "(" var " = " (ls-compile val) ")"))
 934
 935 (define-setf-expander %js-vref (var)
 936   (let ((new-value (gensym)))
 937     (unless (stringp var)
 938       (error "a string was expected"))
 939     (values nil
 940             (list var)
 941             (list new-value)
 942             `(%js-vset ,var ,new-value)
 943             `(%js-vref ,var))))
 944
 945
 946 ;;; Backquote implementation.
 947 ;;;
 948 ;;;    Author: Guy L. Steele Jr.     Date: 27 December 1985
 949 ;;;    Tested under Symbolics Common Lisp and Lucid Common Lisp.
 950 ;;;    This software is in the public domain.
 951
 952 ;;;    The following are unique tokens used during processing.
 953 ;;;    They need not be symbols; they need not even be atoms.
 954 (defvar *comma* 'unquote)
 955 (defvar *comma-atsign* 'unquote-splicing)
 956
 957 (defvar *bq-list* (make-symbol "BQ-LIST"))
 958 (defvar *bq-append* (make-symbol "BQ-APPEND"))
 959 (defvar *bq-list** (make-symbol "BQ-LIST*"))
 960 (defvar *bq-nconc* (make-symbol "BQ-NCONC"))
 961 (defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
 962 (defvar *bq-quote* (make-symbol "BQ-QUOTE"))
 963 (defvar *bq-quote-nil* (list *bq-quote* nil))
 964
 965 ;;; BACKQUOTE is an ordinary macro (not a read-macro) that processes
 966 ;;; the expression foo, looking for occurrences of #:COMMA,
 967 ;;; #:COMMA-ATSIGN, and #:COMMA-DOT.  It constructs code in strict
 968 ;;; accordance with the rules on pages 349-350 of the first edition
 969 ;;; (pages 528-529 of this second edition).  It then optionally
 970 ;;; applies a code simplifier.
 971
 972 ;;; If the value of *BQ-SIMPLIFY* is non-NIL, then BACKQUOTE
 973 ;;; processing applies the code simplifier.  If the value is NIL,
 974 ;;; then the code resulting from BACKQUOTE is exactly that
 975 ;;; specified by the official rules.
 976 (defparameter *bq-simplify* t)
 977
 978 (defmacro backquote (x)
 979   (bq-completely-process x))
 980
 981 ;;; Backquote processing proceeds in three stages:
 982 ;;;
 983 ;;; (1) BQ-PROCESS applies the rules to remove occurrences of
 984 ;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to
 985 ;;; this level of BACKQUOTE.  (It also causes embedded calls to
 986 ;;; BACKQUOTE to be expanded so that nesting is properly handled.)
 987 ;;; Code is produced that is expressed in terms of functions
 988 ;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE.  This is done
 989 ;;; so that the simplifier will simplify only list construction
 990 ;;; functions actually generated by BACKQUOTE and will not involve
 991 ;;; any user code in the simplification.  #:BQ-LIST means LIST,
 992 ;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY
 993 ;;; but indicates places where "%." was used and where NCONC may
 994 ;;; therefore be introduced by the simplifier for efficiency.
 995 ;;;
 996 ;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by
 997 ;;; BQ-PROCESS to produce equivalent but faster code.  The
 998 ;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be
 999 ;;; introduced into the code.
1000 ;;;
1001 ;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces
1002 ;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on.
1003 ;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being
1004 ;;; replaced by its argument).  #:BQ-LIST* is replaced by either
1005 ;;; LIST* or CONS (the latter is used in the two-argument case,
1006 ;;; purely to make the resulting code a tad more readable).
1007
1008 (defun bq-completely-process (x)
1009   (let ((raw-result (bq-process x)))
1010     (bq-remove-tokens (if *bq-simplify*
1011                           (bq-simplify raw-result)
1012                           raw-result))))
1013
1014 (defun bq-process (x)
1015   (cond ((atom x)
1016          (list *bq-quote* x))
1017         ((eq (car x) 'backquote)
1018          (bq-process (bq-completely-process (cadr x))))
1019         ((eq (car x) *comma*) (cadr x))
1020         ((eq (car x) *comma-atsign*)
1021          ;; (error ",@~S after `" (cadr x))
1022          (error "ill-formed"))
1023         ;; ((eq (car x) *comma-dot*)
1024         ;;  ;; (error ",.~S after `" (cadr x))
1025         ;;  (error "ill-formed"))
1026         (t (do ((p x (cdr p))
1027                 (q '() (cons (bracket (car p)) q)))
1028                ((atom p)
1029                 (cons *bq-append*
1030                       (nreconc q (list (list *bq-quote* p)))))
1031              (when (eq (car p) *comma*)
1032                (unless (null (cddr p))
1033                  ;; (error "Malformed ,~S" p)
1034                  (error "Malformed"))
1035                (return (cons *bq-append*
1036                              (nreconc q (list (cadr p))))))
1037              (when (eq (car p) *comma-atsign*)
1038                ;; (error "Dotted ,@~S" p)
1039                (error "Dotted"))
1040              ;; (when (eq (car p) *comma-dot*)
1041              ;;   ;; (error "Dotted ,.~S" p)
1042              ;;   (error "Dotted"))
1043              ))))
1044
1045 ;;; This implements the bracket operator of the formal rules.
1046 (defun bracket (x)
1047   (cond ((atom x)
1048          (list *bq-list* (bq-process x)))
1049         ((eq (car x) *comma*)
1050          (list *bq-list* (cadr x)))
1051         ((eq (car x) *comma-atsign*)
1052          (cadr x))
1053         ;; ((eq (car x) *comma-dot*)
1054         ;;  (list *bq-clobberable* (cadr x)))
1055         (t (list *bq-list* (bq-process x)))))
1056
1057 ;;; This auxiliary function is like MAPCAR but has two extra
1058 ;;; purposes: (1) it handles dotted lists; (2) it tries to make
1059 ;;; the result share with the argument x as much as possible.
1060 (defun maptree (fn x)
1061   (if (atom x)
1062       (funcall fn x)
1063       (let ((a (funcall fn (car x)))
1064             (d (maptree fn (cdr x))))
1065         (if (and (eql a (car x)) (eql d (cdr x)))
1066             x
1067             (cons a d)))))
1068
1069 ;;; This predicate is true of a form that when read looked
1070 ;;; like %@foo or %.foo.
1071 (defun bq-splicing-frob (x)
1072   (and (consp x)
1073        (or (eq (car x) *comma-atsign*)
1074            ;; (eq (car x) *comma-dot*)
1075            )))
1076
1077 ;;; This predicate is true of a form that when read
1078 ;;; looked like %@foo or %.foo or just plain %foo.
1079 (defun bq-frob (x)
1080   (and (consp x)
1081        (or (eq (car x) *comma*)
1082            (eq (car x) *comma-atsign*)
1083            ;; (eq (car x) *comma-dot*)
1084            )))
1085
1086 ;;; The simplifier essentially looks for calls to #:BQ-APPEND and
1087 ;;; tries to simplify them.  The arguments to #:BQ-APPEND are
1088 ;;; processed from right to left, building up a replacement form.
1089 ;;; At each step a number of special cases are handled that,
1090 ;;; loosely speaking, look like this:
1091 ;;;
1092 ;;;  (APPEND (LIST a b c) foo) => (LIST* a b c foo)
1093 ;;;       provided a, b, c are not splicing frobs
1094 ;;;  (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo))
1095 ;;;       provided a, b, c are not splicing frobs
1096 ;;;  (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo)
1097 ;;;  (APPEND (CLOBBERABLE x) foo) => (NCONC x foo)
1098 (defun bq-simplify (x)
1099   (if (atom x)
1100       x
1101       (let ((x (if (eq (car x) *bq-quote*)
1102                    x
1103                    (maptree #'bq-simplify x))))
1104         (if (not (eq (car x) *bq-append*))
1105             x
1106             (bq-simplify-args x)))))
1107
1108 (defun bq-simplify-args (x)
1109   (do ((args (reverse (cdr x)) (cdr args))
1110        (result
1111          nil
1112          (cond ((atom (car args))
1113                 (bq-attach-append *bq-append* (car args) result))
1114                ((and (eq (caar args) *bq-list*)
1115                      (notany #'bq-splicing-frob (cdar args)))
1116                 (bq-attach-conses (cdar args) result))
1117                ((and (eq (caar args) *bq-list**)
1118                      (notany #'bq-splicing-frob (cdar args)))
1119                 (bq-attach-conses
1120                   (reverse (cdr (reverse (cdar args))))
1121                   (bq-attach-append *bq-append*
1122                                     (car (last (car args)))
1123                                     result)))
1124                ((and (eq (caar args) *bq-quote*)
1125                      (consp (cadar args))
1126                      (not (bq-frob (cadar args)))
1127                      (null (cddar args)))
1128                 (bq-attach-conses (list (list *bq-quote*
1129                                               (caadar args)))
1130                                   result))
1131                ((eq (caar args) *bq-clobberable*)
1132                 (bq-attach-append *bq-nconc* (cadar args) result))
1133                (t (bq-attach-append *bq-append*
1134                                     (car args)
1135                                     result)))))
1136       ((null args) result)))
1137
1138 (defun null-or-quoted (x)
1139   (or (null x) (and (consp x) (eq (car x) *bq-quote*))))
1140
1141 ;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND
1142 ;;; or #:BQ-NCONC.  This produces a form (op item result) but
1143 ;;; some simplifications are done on the fly:
1144 ;;;
1145 ;;;  (op '(a b c) '(d e f g)) => '(a b c d e f g)
1146 ;;;  (op item 'nil) => item, provided item is not a splicable frob
1147 ;;;  (op item 'nil) => (op item), if item is a splicable frob
1148 ;;;  (op item (op a b c)) => (op item a b c)
1149 (defun bq-attach-append (op item result)
1150   (cond ((and (null-or-quoted item) (null-or-quoted result))
1151          (list *bq-quote* (append (cadr item) (cadr result))))
1152         ((or (null result) (equal result *bq-quote-nil*))
1153          (if (bq-splicing-frob item) (list op item) item))
1154         ((and (consp result) (eq (car result) op))
1155          (list* (car result) item (cdr result)))
1156         (t (list op item result))))
1157
1158 ;;; The effect of BQ-ATTACH-CONSES is to produce a form as if by
1159 ;;; `(LIST* ,@items ,result) but some simplifications are done
1160 ;;; on the fly.
1161 ;;;
1162 ;;;  (LIST* 'a 'b 'c 'd) => '(a b c . d)
1163 ;;;  (LIST* a b c 'nil) => (LIST a b c)
1164 ;;;  (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g)
1165 ;;;  (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g)
1166 (defun bq-attach-conses (items result)
1167   (cond ((and (every #'null-or-quoted items)
1168               (null-or-quoted result))
1169          (list *bq-quote*
1170                (append (mapcar #'cadr items) (cadr result))))
1171         ((or (null result) (equal result *bq-quote-nil*))
1172          (cons *bq-list* items))
1173         ((and (consp result)
1174               (or (eq (car result) *bq-list*)
1175                   (eq (car result) *bq-list**)))
1176          (cons (car result) (append items (cdr result))))
1177         (t (cons *bq-list** (append items (list result))))))
1178
1179 ;;; Removes funny tokens and changes (#:BQ-LIST* a b) into
1180 ;;; (CONS a b) instead of (LIST* a b), purely for readability.
1181 (defun bq-remove-tokens (x)
1182   (cond ((eq x *bq-list*) 'list)
1183         ((eq x *bq-append*) 'append)
1184         ((eq x *bq-nconc*) 'nconc)
1185         ((eq x *bq-list**) 'list*)
1186         ((eq x *bq-quote*) 'quote)
1187         ((atom x) x)
1188         ((eq (car x) *bq-clobberable*)
1189          (bq-remove-tokens (cadr x)))
1190         ((and (eq (car x) *bq-list**)
1191               (consp (cddr x))
1192               (null (cdddr x)))
1193          (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
1194         (t (maptree #'bq-remove-tokens x))))
1195
1196 (define-transformation backquote (form)
1197   (bq-completely-process form))
1198
1199
1200 ;;; Primitives
1201
1202 (defvar *builtins* nil)
1203
1204 (defmacro define-raw-builtin (name args &body body)
1205   ;; Creates a new primitive function `name' with parameters args and
1206   ;; @body. The body can access to the local environment through the
1207   ;; variable *ENVIRONMENT*.
1208   `(push (list ',name (lambda ,args (block ,name ,@body)))
1209          *builtins*))
1210
1211 (defmacro define-builtin (name args &body body)
1212   `(define-raw-builtin ,name ,args
1213      (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)
1214        ,@body)))
1215
1216 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
1217 (defmacro type-check (decls &body body)
1218   `(js!selfcall
1219      ,@(mapcar (lambda (decl)
1220                  `(code "var " ,(first decl) " = " ,(third decl) ";" *newline*))
1221                decls)
1222      ,@(mapcar (lambda (decl)
1223                  `(code "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline*
1224                         (indent "throw 'The value ' + "
1225                                 ,(first decl)
1226                                 " + ' is not a type "
1227                                 ,(second decl)
1228                                 ".';"
1229                                 *newline*)))
1230                decls)
1231      (code "return " (progn ,@body) ";" *newline*)))
1232
1233 ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
1234 ;;; a variable which holds a list of forms. It will compile them and
1235 ;;; store the result in some Javascript variables. BODY is evaluated
1236 ;;; with ARGS bound to the list of these variables to generate the
1237 ;;; code which performs the transformation on these variables.
1238
1239 (defun variable-arity-call (args function)
1240   (unless (consp args)
1241     (error "ARGS must be a non-empty list"))
1242   (let ((counter 0)
1243         (fargs '())
1244         (prelude ""))
1245     (dolist (x args)
1246       (if (numberp x)
1247           (push (integer-to-string x) fargs)
1248           (let ((v (code "x" (incf counter))))
1249             (push v fargs)
1250             (concatf prelude
1251               (code "var " v " = " (ls-compile x) ";" *newline*
1252                     "if (typeof " v " !== 'number') throw 'Not a number!';"
1253                     *newline*)))))
1254     (js!selfcall prelude (funcall function (reverse fargs)))))
1255
1256
1257 (defmacro variable-arity (args &body body)
1258   (unless (symbolp args)
1259     (error "Bad usage of VARIABLE-ARITY, you must pass a symbol"))
1260   `(variable-arity-call ,args
1261                         (lambda (,args)
1262                           (code "return " ,@body ";" *newline*))))
1263
1264 (defun num-op-num (x op y)
1265   (type-check (("x" "number" x) ("y" "number" y))
1266     (code "x" op "y")))
1267
1268 (define-raw-builtin + (&rest numbers)
1269   (if (null numbers)
1270       "0"
1271       (variable-arity numbers
1272         (join numbers "+"))))
1273
1274 (define-raw-builtin - (x &rest others)
1275   (let ((args (cons x others)))
1276     (variable-arity args
1277       (if (null others)
1278           (concat "-" (car args))
1279           (join args "-")))))
1280
1281 (define-raw-builtin * (&rest numbers)
1282   (if (null numbers)
1283       "1"
1284       (variable-arity numbers
1285         (join numbers "*"))))
1286
1287 (define-raw-builtin / (x &rest others)
1288   (let ((args (cons x others)))
1289     (variable-arity args
1290       (if (null others)
1291           (concat "1 /" (car args))
1292           (join args "/")))))
1293
1294 (define-builtin mod (x y) (num-op-num x "%" y))
1295
1296
1297 (defun comparison-conjuntion (vars op)
1298   (cond
1299     ((null (cdr vars))
1300      "true")
1301     ((null (cddr vars))
1302      (concat (car vars) op (cadr vars)))
1303     (t
1304      (concat (car vars) op (cadr vars)
1305              " && "
1306              (comparison-conjuntion (cdr vars) op)))))
1307
1308 (defmacro define-builtin-comparison (op sym)
1309   `(define-raw-builtin ,op (x &rest args)
1310      (let ((args (cons x args)))
1311        (variable-arity args
1312          (js!bool (comparison-conjuntion args ,sym))))))
1313
1314 (define-builtin-comparison > ">")
1315 (define-builtin-comparison < "<")
1316 (define-builtin-comparison >= ">=")
1317 (define-builtin-comparison <= "<=")
1318 (define-builtin-comparison = "==")
1319
1320 (define-builtin numberp (x)
1321   (js!bool (code "(typeof (" x ") == \"number\")")))
1322
1323 (define-builtin floor (x)
1324   (type-check (("x" "number" x))
1325     "Math.floor(x)"))
1326
1327 (define-builtin cons (x y)
1328   (code "({car: " x ", cdr: " y "})"))
1329
1330 (define-builtin consp (x)
1331   (js!bool
1332    (js!selfcall
1333      "var tmp = " x ";" *newline*
1334      "return (typeof tmp == 'object' && 'car' in tmp);" *newline*)))
1335
1336 (define-builtin car (x)
1337   (js!selfcall
1338     "var tmp = " x ";" *newline*
1339     "return tmp === " (ls-compile nil)
1340     "? " (ls-compile nil)
1341     ": tmp.car;" *newline*))
1342
1343 (define-builtin cdr (x)
1344   (js!selfcall
1345     "var tmp = " x ";" *newline*
1346     "return tmp === " (ls-compile nil) "? "
1347     (ls-compile nil)
1348     ": tmp.cdr;" *newline*))
1349
1350 (define-builtin rplaca (x new)
1351   (type-check (("x" "object" x))
1352     (code "(x.car = " new ", x)")))
1353
1354 (define-builtin rplacd (x new)
1355   (type-check (("x" "object" x))
1356     (code "(x.cdr = " new ", x)")))
1357
1358 (define-builtin symbolp (x)
1359   (js!bool
1360    (js!selfcall
1361      "var tmp = " x ";" *newline*
1362      "return (typeof tmp == 'object' && 'name' in tmp);" *newline*)))
1363
1364 (define-builtin make-symbol (name)
1365   (type-check (("name" "string" name))
1366     "({name: name})"))
1367
1368 (define-builtin symbol-name (x)
1369   (code "(" x ").name"))
1370
1371 (define-builtin set (symbol value)
1372   (code "(" symbol ").value = " value))
1373
1374 (define-builtin fset (symbol value)
1375   (code "(" symbol ").fvalue = " value))
1376
1377 (define-builtin boundp (x)
1378   (js!bool (code "(" x ".value !== undefined)")))
1379
1380 (define-builtin symbol-value (x)
1381   (js!selfcall
1382     "var symbol = " x ";" *newline*
1383     "var value = symbol.value;" *newline*
1384     "if (value === undefined) throw \"Variable `\" + symbol.name + \"' is unbound.\";" *newline*
1385     "return value;" *newline*))
1386
1387 (define-builtin symbol-function (x)
1388   (js!selfcall
1389     "var symbol = " x ";" *newline*
1390     "var func = symbol.fvalue;" *newline*
1391     "if (func === undefined) throw \"Function `\" + symbol.name + \"' is undefined.\";" *newline*
1392     "return func;" *newline*))
1393
1394 (define-builtin symbol-plist (x)
1395   (code "((" x ").plist || " (ls-compile nil) ")"))
1396
1397 (define-builtin lambda-code (x)
1398   (code "(" x ").toString()"))
1399
1400 (define-builtin eq    (x y) (js!bool (code "(" x " === " y ")")))
1401 (define-builtin equal (x y) (js!bool (code "(" x  " == " y ")")))
1402
1403 (define-builtin char-to-string (x)
1404   (type-check (("x" "number" x))
1405     "String.fromCharCode(x)"))
1406
1407 (define-builtin stringp (x)
1408   (js!bool (code "(typeof(" x ") == \"string\")")))
1409
1410 (define-builtin string-upcase (x)
1411   (type-check (("x" "string" x))
1412     "x.toUpperCase()"))
1413
1414 (define-builtin string-length (x)
1415   (type-check (("x" "string" x))
1416     "x.length"))
1417
1418 (define-raw-builtin slice (string a &optional b)
1419   (js!selfcall
1420     "var str = " (ls-compile string) ";" *newline*
1421     "var a = " (ls-compile a) ";" *newline*
1422     "var b;" *newline*
1423     (when b (code "b = " (ls-compile b) ";" *newline*))
1424     "return str.slice(a,b);" *newline*))
1425
1426 (define-builtin char (string index)
1427   (type-check (("string" "string" string)
1428                ("index" "number" index))
1429     "string.charCodeAt(index)"))
1430
1431 (define-builtin concat-two (string1 string2)
1432   (type-check (("string1" "string" string1)
1433                ("string2" "string" string2))
1434     "string1.concat(string2)"))
1435
1436 (define-raw-builtin funcall (func &rest args)
1437   (js!selfcall
1438     "var f = " (ls-compile func) ";" *newline*
1439     "return (typeof f === 'function'? f: f.fvalue)("
1440     (join (cons (if *multiple-value-p* "values" "pv")
1441                 (mapcar #'ls-compile args))
1442           ", ")
1443     ")"))
1444
1445 (define-raw-builtin apply (func &rest args)
1446   (if (null args)
1447       (code "(" (ls-compile func) ")()")
1448       (let ((args (butlast args))
1449             (last (car (last args))))
1450         (js!selfcall
1451           "var f = " (ls-compile func) ";" *newline*
1452           "var args = [" (join (cons (if *multiple-value-p* "values" "pv")
1453                                      (mapcar #'ls-compile args))
1454                                ", ")
1455           "];" *newline*
1456           "var tail = (" (ls-compile last) ");" *newline*
1457           "while (tail != " (ls-compile nil) "){" *newline*
1458           "    args.push(tail.car);" *newline*
1459           "    tail = tail.cdr;" *newline*
1460           "}" *newline*
1461           "return (typeof f === 'function'? f : f.fvalue).apply(this, args);" *newline*))))
1462
1463 (define-builtin js-eval (string)
1464   (type-check (("string" "string" string))
1465     (if *multiple-value-p*
1466         (js!selfcall
1467           "var v = eval.apply(window, [string]);" *newline*
1468           "if (typeof v !== 'object' || !('multiple-value' in v)){" *newline*
1469           (indent "v = [v];" *newline*
1470                   "v['multiple-value'] = true;" *newline*)
1471           "}" *newline*
1472           "return values.apply(this, v);" *newline*)
1473         "eval.apply(window, [string])")))
1474
1475 (define-builtin error (string)
1476   (js!selfcall "throw " string ";" *newline*))
1477
1478 (define-builtin new () "{}")
1479
1480 (define-builtin objectp (x)
1481   (js!bool (code "(typeof (" x ") === 'object')")))
1482
1483 (define-builtin oget (object key)
1484   (js!selfcall
1485     "var tmp = " "(" object ")[" key "];" *newline*
1486     "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))
1487
1488 (define-builtin oset (object key value)
1489   (code "((" object ")[" key "] = " value ")"))
1490
1491 (define-builtin in (key object)
1492   (js!bool (code "((" key ") in (" object "))")))
1493
1494 (define-builtin functionp (x)
1495   (js!bool (code "(typeof " x " == 'function')")))
1496
1497 (define-builtin write-string (x)
1498   (type-check (("x" "string" x))
1499     "lisp.write(x)"))
1500
1501 (define-builtin make-array (n)
1502   (js!selfcall
1503     "var r = [];" *newline*
1504     "for (var i = 0; i < " n "; i++)" *newline*
1505     (indent "r.push(" (ls-compile nil) ");" *newline*)
1506     "return r;" *newline*))
1507
1508 (define-builtin arrayp (x)
1509   (js!bool
1510    (js!selfcall
1511      "var x = " x ";" *newline*
1512      "return typeof x === 'object' && 'length' in x;")))
1513
1514 (define-builtin aref (array n)
1515   (js!selfcall
1516     "var x = " "(" array ")[" n "];" *newline*
1517     "if (x === undefined) throw 'Out of range';" *newline*
1518     "return x;" *newline*))
1519
1520 (define-builtin aset (array n value)
1521   (js!selfcall
1522     "var x = " array ";" *newline*
1523     "var i = " n ";" *newline*
1524     "if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
1525     "return x[i] = " value ";" *newline*))
1526
1527 (define-builtin get-unix-time ()
1528   (code "(Math.round(new Date() / 1000))"))
1529
1530 (define-builtin values-array (array)
1531   (if *multiple-value-p*
1532       (code "values.apply(this, " array ")")
1533       (code "pv.apply(this, " array ")")))
1534
1535 (define-raw-builtin values (&rest args)
1536   (if *multiple-value-p*
1537       (code "values(" (join (mapcar #'ls-compile args) ", ") ")")
1538       (code "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
1539
1540 ;; Receives the JS function as first argument as a literal string. The
1541 ;; second argument is compiled and should evaluate to a vector of
1542 ;; values to apply to the the function. The result returned.
1543 (define-builtin %js-call (fun args)
1544   (code fun ".apply(this, " args ")"))
1545
1546 (defun macro (x)
1547   (and (symbolp x)
1548        (let ((b (lookup-in-lexenv x *environment* 'function)))
1549          (if (and b (eq (binding-type b) 'macro))
1550              b
1551              nil))))
1552
1553 #+common-lisp
1554 (defvar *macroexpander-cache*
1555   (make-hash-table :test #'eq))
1556
1557 (defun ls-macroexpand-1 (form)
1558   (cond
1559     ((symbolp form)
1560      (let ((b (lookup-in-lexenv form *environment* 'variable)))
1561        (if (and b (eq (binding-type b) 'macro))
1562            (values (binding-value b) t)
1563            (values form nil))))
1564     ((consp form)
1565      (let ((macro-binding (macro (car form))))
1566        (if macro-binding
1567            (let ((expander (binding-value macro-binding)))
1568              (cond
1569                #+common-lisp
1570                ((gethash macro-binding *macroexpander-cache*)
1571                 (setq expander (gethash macro-binding *macroexpander-cache*)))
1572                ((listp expander)
1573                 (let ((compiled (eval expander)))
1574                   ;; The list representation are useful while
1575                   ;; bootstrapping, as we can dump the definition of the
1576                   ;; macros easily, but they are slow because we have to
1577                   ;; evaluate them and compile them now and again. So, let
1578                   ;; us replace the list representation version of the
1579                   ;; function with the compiled one.
1580                   ;;
1581                   #+ecmalisp (setf (binding-value macro-binding) compiled)
1582                   #+common-lisp (setf (gethash macro-binding *macroexpander-cache*) compiled)
1583                   (setq expander compiled))))
1584              (values (apply expander (cdr form)) t))
1585            (values form nil))))
1586     (t
1587      (values form nil))))
1588
1589 (defun compile-funcall (function args)
1590   (let* ((values-funcs (if *multiple-value-p* "values" "pv"))
1591          (arglist (concat "(" (join (cons values-funcs (mapcar #'ls-compile args)) ", ") ")")))
1592     (cond
1593       ((translate-function function)
1594        (concat (translate-function function) arglist))
1595       ((and (symbolp function)
1596             #+ecmalisp (eq (symbol-package function) (find-package "COMMON-LISP"))
1597             #+common-lisp t)
1598        (code (ls-compile `',function) ".fvalue" arglist))
1599       (t
1600        (code (ls-compile `#',function) arglist)))))
1601
1602 (defun ls-compile-block (sexps &optional return-last-p)
1603   (if return-last-p
1604       (code (ls-compile-block (butlast sexps))
1605             "return " (ls-compile (car (last sexps)) *multiple-value-p*) ";")
1606       (join-trailing
1607        (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
1608        (concat ";" *newline*))))
1609
1610 (defun ls-compile (sexp &optional multiple-value-p)
1611   (multiple-value-bind (sexp expandedp) (ls-macroexpand-1 sexp)
1612     (when expandedp
1613       (return-from ls-compile (ls-compile sexp multiple-value-p)))
1614     ;; The expression has been macroexpanded. Now compile it!
1615     (let ((*multiple-value-p* multiple-value-p))
1616       (cond
1617         ((symbolp sexp)
1618          (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
1619            (cond
1620              ((and b (not (member 'special (binding-declarations b))))
1621               (binding-value b))
1622              ((or (keywordp sexp)
1623                   (and b (member 'constant (binding-declarations b))))
1624               (code (ls-compile `',sexp) ".value"))
1625              (t
1626               (ls-compile `(symbol-value ',sexp))))))
1627         ((integerp sexp) (integer-to-string sexp))
1628         ((stringp sexp) (code "\"" (escape-string sexp) "\""))
1629         ((arrayp sexp) (literal sexp))
1630         ((listp sexp)
1631          (let ((name (car sexp))
1632                (args (cdr sexp)))
1633            (cond
1634              ;; Special forms
1635              ((assoc name *compilations*)
1636               (let ((comp (second (assoc name *compilations*))))
1637                 (apply comp args)))
1638              ;; Built-in functions
1639              ((and (assoc name *builtins*)
1640                    (not (claimp name 'function 'notinline)))
1641               (let ((comp (second (assoc name *builtins*))))
1642                 (apply comp args)))
1643              (t
1644               (compile-funcall name args)))))
1645         (t
1646          (error (concat "How should I compile " (prin1-to-string sexp) "?")))))))
1647
1648
1649 (defvar *compile-print-toplevels* nil)
1650
1651 (defun truncate-string (string &optional (width 60))
1652   (let ((n (or (position #\newline string)
1653                (min width (length string)))))
1654     (subseq string 0 n)))
1655
1656 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
1657   (let ((*toplevel-compilations* nil))
1658     (cond
1659       ((and (consp sexp) (eq (car sexp) 'progn))
1660        (let ((subs (mapcar (lambda (s)
1661                              (ls-compile-toplevel s t))
1662                            (cdr sexp))))
1663          (join (remove-if #'null-or-empty-p subs))))
1664       (t
1665        (when *compile-print-toplevels*
1666          (let ((form-string (prin1-to-string sexp)))
1667            (write-string "Compiling ")
1668            (write-string (truncate-string form-string))
1669            (write-line "...")))
1670
1671        (let ((code (ls-compile sexp multiple-value-p)))
1672          (code (join-trailing (get-toplevel-compilations)
1673                               (code ";" *newline*))
1674                (when code
1675                  (code code ";" *newline*))))))))