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