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