ecmalisp.lisp

   1 ;;; ecmalisp.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 #+common-lisp
  20 (eval-when (:load-toplevel :compile-toplevel :execute)
  21   (load "compat"))
  22
  23 ;;; At this point, no matter if Common Lisp or ecmalisp is compiling
  24 ;;; from here, this code will compile on both. We define some helper
  25 ;;; functions now for string manipulation and so on. They will be
  26 ;;; useful in the compiler, mostly.
  27
  28 (defvar *newline* (string (code-char 10)))
  29
  30 #+ecmalisp
  31 (defun concat (&rest strs)
  32   (!reduce #'concat-two strs :initial-value ""))
  33 #+common-lisp
  34 (eval-when (:compile-toplevel :load-toplevel :execute)
  35   (defun concat (&rest strs)
  36     (apply #'concatenate 'string strs)))
  37
  38 (defmacro concatf (variable &body form)
  39   `(setq ,variable (concat ,variable (progn ,@form))))
  40
  41 ;;; This couple of helper functions will be defined in both Common
  42 ;;; Lisp and in Ecmalisp.
  43 (defun ensure-list (x)
  44   (if (listp x)
  45       x
  46       (list x)))
  47
  48 (defun !reduce (func list &key initial-value)
  49   (if (null list)
  50       initial-value
  51       (!reduce func
  52                (cdr list)
  53                :initial-value (funcall func initial-value (car list)))))
  54
  55 ;;; Concatenate a list of strings, with a separator
  56 (defun join (list &optional (separator ""))
  57   (cond
  58     ((null list)
  59      "")
  60     ((null (cdr list))
  61      (car list))
  62     (t
  63      (concat (car list)
  64              separator
  65              (join (cdr list) separator)))))
  66
  67 (defun join-trailing (list &optional (separator ""))
  68   (if (null list)
  69       ""
  70       (concat (car list) separator (join-trailing (cdr list) separator))))
  71
  72 (defun mapconcat (func list)
  73   (join (mapcar func list)))
  74
  75 (defun vector-to-list (vector)
  76   (let ((list nil)
  77         (size (length vector)))
  78     (dotimes (i size (reverse list))
  79       (push (aref vector i) list))))
  80
  81 (defun list-to-vector (list)
  82   (let ((v (make-array (length list)))
  83         (i 0))
  84     (dolist (x list v)
  85       (aset v i x)
  86       (incf i))))
  87
  88 (defmacro awhen (condition &body body)
  89   `(let ((it ,condition))
  90      (when it ,@body)))
  91
  92 #+ecmalisp
  93 (progn
  94   (defun values-list (list)
  95     (values-array (list-to-vector list)))
  96
  97   (defun values (&rest args)
  98     (values-list args)))
  99
 100 (defun integer-to-string (x)
 101   (cond
 102     ((zerop x)
 103      "0")
 104     ((minusp x)
 105      (concat "-" (integer-to-string (- 0 x))))
 106     (t
 107      (let ((digits nil))
 108        (while (not (zerop x))
 109          (push (mod x 10) digits)
 110          (setq x (truncate x 10)))
 111        (mapconcat (lambda (x) (string (digit-char x)))
 112                   digits)))))
 113
 114
 115 ;;; Printer
 116
 117 #+ecmalisp
 118 (progn
 119   (defun prin1-to-string (form)
 120     (cond
 121       ((symbolp form)
 122        (multiple-value-bind (symbol foundp)
 123            (find-symbol (symbol-name form) *package*)
 124          (if (and foundp (eq symbol form))
 125              (symbol-name form)
 126              (let ((package (symbol-package form))
 127                    (name (symbol-name form)))
 128                (concat (cond
 129                          ((null package) "#")
 130                          ((eq package (find-package "KEYWORD")) "")
 131                          (t (package-name package)))
 132                        ":" name)))))
 133       ((integerp form) (integer-to-string form))
 134       ((stringp form) (concat "\"" (escape-string form) "\""))
 135       ((functionp form)
 136        (let ((name (oget form "fname")))
 137          (if name
 138              (concat "#<FUNCTION " name ">")
 139              (concat "#<FUNCTION>"))))
 140       ((listp form)
 141        (concat "("
 142                (join-trailing (mapcar #'prin1-to-string (butlast form)) " ")
 143                (let ((last (last form)))
 144                  (if (null (cdr last))
 145                      (prin1-to-string (car last))
 146                      (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
 147                ")"))
 148       ((arrayp form)
 149        (concat "#" (if (zerop (length form))
 150                        "()"
 151                        (prin1-to-string (vector-to-list form)))))
 152       ((packagep form)
 153        (concat "#<PACKAGE " (package-name form) ">"))
 154       (t
 155        (concat "#<javascript object>"))))
 156
 157   (defun write-line (x)
 158     (write-string x)
 159     (write-string *newline*)
 160     x)
 161
 162   (defun warn (string)
 163     (write-string "WARNING: ")
 164     (write-line string))
 165
 166   (defun print (x)
 167     (write-line (prin1-to-string x))
 168     x))
 169
 170
 171
 172 ;;;; Reader
 173
 174 ;;; The Lisp reader, parse strings and return Lisp objects. The main
 175 ;;; entry points are `ls-read' and `ls-read-from-string'.
 176
 177 (defun make-string-stream (string)
 178   (cons string 0))
 179
 180 (defun %peek-char (stream)
 181   (and (< (cdr stream) (length (car stream)))
 182        (char (car stream) (cdr stream))))
 183
 184 (defun %read-char (stream)
 185   (and (< (cdr stream) (length (car stream)))
 186        (prog1 (char (car stream) (cdr stream))
 187          (rplacd stream (1+ (cdr stream))))))
 188
 189 (defun whitespacep (ch)
 190   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
 191
 192 (defun skip-whitespaces (stream)
 193   (let (ch)
 194     (setq ch (%peek-char stream))
 195     (while (and ch (whitespacep ch))
 196       (%read-char stream)
 197       (setq ch (%peek-char stream)))))
 198
 199 (defun terminalp (ch)
 200   (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
 201
 202 (defun read-until (stream func)
 203   (let ((string "")
 204         (ch))
 205     (setq ch (%peek-char stream))
 206     (while (and ch (not (funcall func ch)))
 207       (setq string (concat string (string ch)))
 208       (%read-char stream)
 209       (setq ch (%peek-char stream)))
 210     string))
 211
 212 (defun skip-whitespaces-and-comments (stream)
 213   (let (ch)
 214     (skip-whitespaces stream)
 215     (setq ch (%peek-char stream))
 216     (while (and ch (char= ch #\;))
 217       (read-until stream (lambda (x) (char= x #\newline)))
 218       (skip-whitespaces stream)
 219       (setq ch (%peek-char stream)))))
 220
 221 (defun %read-list (stream)
 222   (skip-whitespaces-and-comments stream)
 223   (let ((ch (%peek-char stream)))
 224     (cond
 225       ((null ch)
 226        (error "Unspected EOF"))
 227       ((char= ch #\))
 228        (%read-char stream)
 229        nil)
 230       ((char= ch #\.)
 231        (%read-char stream)
 232        (prog1 (ls-read stream)
 233          (skip-whitespaces-and-comments stream)
 234          (unless (char= (%read-char stream) #\))
 235            (error "')' was expected."))))
 236       (t
 237        (cons (ls-read stream) (%read-list stream))))))
 238
 239 (defun read-string (stream)
 240   (let ((string "")
 241         (ch nil))
 242     (setq ch (%read-char stream))
 243     (while (not (eql ch #\"))
 244       (when (null ch)
 245         (error "Unexpected EOF"))
 246       (when (eql ch #\\)
 247         (setq ch (%read-char stream)))
 248       (setq string (concat string (string ch)))
 249       (setq ch (%read-char stream)))
 250     string))
 251
 252 (defun read-sharp (stream)
 253   (%read-char stream)
 254   (ecase (%read-char stream)
 255     (#\'
 256      (list 'function (ls-read stream)))
 257     (#\( (list-to-vector (%read-list stream)))
 258     (#\: (make-symbol (string-upcase (read-until stream #'terminalp))))
 259     (#\\
 260      (let ((cname
 261             (concat (string (%read-char stream))
 262                     (read-until stream #'terminalp))))
 263        (cond
 264          ((string= cname "space") (char-code #\space))
 265          ((string= cname "tab") (char-code #\tab))
 266          ((string= cname "newline") (char-code #\newline))
 267          (t (char-code (char cname 0))))))
 268     (#\+
 269      (let ((feature (read-until stream #'terminalp)))
 270        (cond
 271          ((string= feature "common-lisp")
 272           (ls-read stream)              ;ignore
 273           (ls-read stream))
 274          ((string= feature "ecmalisp")
 275           (ls-read stream))
 276          (t
 277           (error "Unknown reader form.")))))))
 278
 279 ;;; Parse a string of the form NAME, PACKAGE:NAME or
 280 ;;; PACKAGE::NAME and return the name. If the string is of the
 281 ;;; form 1) or 3), but the symbol does not exist, it will be created
 282 ;;; and interned in that package.
 283 (defun read-symbol (string)
 284   (let ((size (length string))
 285         package name internalp index)
 286     (setq index 0)
 287     (while (and (< index size)
 288                 (not (char= (char string index) #\:)))
 289       (incf index))
 290     (cond
 291       ;; No package prefix
 292       ((= index size)
 293        (setq name string)
 294        (setq package *package*)
 295        (setq internalp t))
 296       (t
 297        ;; Package prefix
 298        (if (zerop index)
 299            (setq package "KEYWORD")
 300            (setq package (string-upcase (subseq string 0 index))))
 301        (incf index)
 302        (when (char= (char string index) #\:)
 303          (setq internalp t)
 304          (incf index))
 305        (setq name (subseq string index))))
 306     ;; Canonalize symbol name and package
 307     (when (not (eq package "JS"))
 308       (setq name (string-upcase name)))
 309     (setq package (find-package package))
 310     ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an
 311     ;; external symbol from PACKAGE.
 312     (if (or internalp
 313             (eq package (find-package "KEYWORD"))
 314             (eq package (find-package "JS")))
 315         (intern name package)
 316         (find-symbol name package))))
 317
 318
 319 (defun !parse-integer (string junk-allow)
 320   (block nil
 321     (let ((value 0)
 322           (index 0)
 323           (size (length string))
 324           (sign 1))
 325       ;; Leading whitespace
 326       (while (and (< index size)
 327                   (whitespacep (char string index)))
 328         (incf index))
 329       (unless (< index size) (return (values nil 0)))
 330       ;; Optional sign
 331       (case (char string 0)
 332         (#\+ (incf index))
 333         (#\- (setq sign -1)
 334              (incf index)))
 335       ;; First digit
 336       (unless (and (< index size)
 337                    (setq value (digit-char-p (char string index))))
 338         (return (values nil index)))
 339       (incf index)
 340       ;; Other digits
 341       (while (< index size)
 342         (let ((digit (digit-char-p (char string index))))
 343           (unless digit (return))
 344           (setq value (+ (* value 10) digit))
 345           (incf index)))
 346       ;; Trailing whitespace
 347       (do ((i index (1+ i)))
 348           ((or (= i size) (not (whitespacep (char string i))))
 349            (and (= i size) (setq index i))))
 350       (if (or junk-allow
 351               (= index size))
 352           (values (* sign value) index)
 353           (values nil index)))))
 354
 355 #+ecmalisp
 356 (defun parse-integer (string &key junk-allowed)
 357   (multiple-value-bind (num index)
 358       (!parse-integer string junk-allowed)
 359     (when num
 360       (values num index)
 361       (error "junk detected."))))
 362
 363 (defvar *eof* (gensym))
 364 (defun ls-read (stream)
 365   (skip-whitespaces-and-comments stream)
 366   (let ((ch (%peek-char stream)))
 367     (cond
 368       ((or (null ch) (char= ch #\)))
 369        *eof*)
 370       ((char= ch #\()
 371        (%read-char stream)
 372        (%read-list stream))
 373       ((char= ch #\')
 374        (%read-char stream)
 375        (list 'quote (ls-read stream)))
 376       ((char= ch #\`)
 377        (%read-char stream)
 378        (list 'backquote (ls-read stream)))
 379       ((char= ch #\")
 380        (%read-char stream)
 381        (read-string stream))
 382       ((char= ch #\,)
 383        (%read-char stream)
 384        (if (eql (%peek-char stream) #\@)
 385            (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
 386            (list 'unquote (ls-read stream))))
 387       ((char= ch #\#)
 388        (read-sharp stream))
 389       (t
 390        (let ((string (read-until stream #'terminalp)))
 391          (or (values (!parse-integer string nil))
 392              (read-symbol string)))))))
 393
 394 (defun ls-read-from-string (string)
 395   (ls-read (make-string-stream string)))
 396
 397
 398 ;;;; Compiler
 399
 400 ;;; Translate the Lisp code to Javascript. It will compile the special
 401 ;;; forms. Some primitive functions are compiled as special forms
 402 ;;; too. The respective real functions are defined in the target (see
 403 ;;; the beginning of this file) as well as some primitive functions.
 404
 405 (defun code (&rest args)
 406   (mapconcat (lambda (arg)
 407                (cond
 408                  ((null arg) "")
 409                  ((integerp arg) (integer-to-string arg))
 410                  ((stringp arg) arg)
 411                  (t (error "Unknown argument."))))
 412              args))
 413
 414 ;;; Wrap X with a Javascript code to convert the result from
 415 ;;; Javascript generalized booleans to T or NIL.
 416 (defun js!bool (x)
 417   (code "(" x "?" (ls-compile t) ": " (ls-compile nil) ")"))
 418
 419 ;;; Concatenate the arguments and wrap them with a self-calling
 420 ;;; Javascript anonymous function. It is used to make some Javascript
 421 ;;; statements valid expressions and provide a private scope as well.
 422 ;;; It could be defined as function, but we could do some
 423 ;;; preprocessing in the future.
 424 (defmacro js!selfcall (&body body)
 425   `(code "(function(){" *newline* (indent ,@body) "})()"))
 426
 427 ;;; Like CODE, but prefix each line with four spaces. Two versions
 428 ;;; of this function are available, because the Ecmalisp version is
 429 ;;; very slow and bootstraping was annoying.
 430
 431 #+ecmalisp
 432 (defun indent (&rest string)
 433   (let ((input (apply #'code string)))
 434     (let ((output "")
 435           (index 0)
 436           (size (length input)))
 437       (when (plusp (length input)) (concatf output "    "))
 438       (while (< index size)
 439         (let ((str
 440                (if (and (char= (char input index) #\newline)
 441                         (< index (1- size))
 442                         (not (char= (char input (1+ index)) #\newline)))
 443                    (concat (string #\newline) "    ")
 444                    (string (char input index)))))
 445           (concatf output str))
 446         (incf index))
 447       output)))
 448
 449 #+common-lisp
 450 (defun indent (&rest string)
 451   (with-output-to-string (*standard-output*)
 452     (with-input-from-string (input (apply #'code string))
 453       (loop
 454          for line = (read-line input nil)
 455          while line
 456          do (write-string "    ")
 457          do (write-line line)))))
 458
 459
 460 ;;; A Form can return a multiple values object calling VALUES, like
 461 ;;; values(arg1, arg2, ...). It will work in any context, as well as
 462 ;;; returning an individual object. However, if the special variable
 463 ;;; `*multiple-value-p*' is NIL, is granted that only the primary
 464 ;;; value will be used, so we can optimize to avoid the VALUES
 465 ;;; function call.
 466 (defvar *multiple-value-p* nil)
 467
 468 ;; A very simple defstruct built on lists. It supports just slot with
 469 ;; an optional default initform, and it will create a constructor,
 470 ;; predicate and accessors for you.
 471 (defmacro def!struct (name &rest slots)
 472   (unless (symbolp name)
 473     (error "It is not a full defstruct implementation."))
 474   (let* ((name-string (symbol-name name))
 475          (slot-descriptions
 476           (mapcar (lambda (sd)
 477                     (cond
 478                       ((symbolp sd)
 479                        (list sd))
 480                       ((and (listp sd) (car sd) (cddr sd))
 481                        sd)
 482                       (t
 483                        (error "Bad slot accessor."))))
 484                   slots))
 485          (predicate (intern (concat name-string "-P"))))
 486     `(progn
 487        ;; Constructor
 488        (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
 489          (list ',name ,@(mapcar #'car slot-descriptions)))
 490        ;; Predicate
 491        (defun ,predicate (x)
 492          (and (consp x) (eq (car x) ',name)))
 493        ;; Copier
 494        (defun ,(intern (concat "COPY-" name-string)) (x)
 495          (copy-list x))
 496        ;; Slot accessors
 497        ,@(with-collect
 498           (let ((index 1))
 499             (dolist (slot slot-descriptions)
 500               (let* ((name (car slot))
 501                      (accessor-name (intern (concat name-string "-" (string name)))))
 502                 (collect
 503                     `(defun ,accessor-name (x)
 504                        (unless (,predicate x)
 505                          (error ,(concat "The object is not a type " name-string)))
 506                        (nth ,index x)))
 507                 ;; TODO: Implement this with a higher level
 508                 ;; abstraction like defsetf or (defun (setf ..))
 509                 (collect
 510                     `(define-setf-expander ,accessor-name (x)
 511                        (let ((object (gensym))
 512                              (new-value (gensym)))
 513                          (values (list object)
 514                                  (list x)
 515                                  (list new-value)
 516                                  `(progn
 517                                     (rplaca (nthcdr ,',index ,object) ,new-value)
 518                                     ,new-value)
 519                                  `(,',accessor-name ,object)))))
 520                 (incf index)))))
 521        ',name)))
 522
 523
 524 ;;; Environment
 525
 526 (def!struct binding
 527   name
 528   type
 529   value
 530   declarations)
 531
 532 (def!struct lexenv
 533   variable
 534   function
 535   block
 536   gotag)
 537
 538 (defun lookup-in-lexenv (name lexenv namespace)
 539   (find name (ecase namespace
 540                 (variable (lexenv-variable lexenv))
 541                 (function (lexenv-function lexenv))
 542                 (block    (lexenv-block    lexenv))
 543                 (gotag    (lexenv-gotag    lexenv)))
 544         :key #'binding-name))
 545
 546 (defun push-to-lexenv (binding lexenv namespace)
 547   (ecase namespace
 548     (variable (push binding (lexenv-variable lexenv)))
 549     (function (push binding (lexenv-function lexenv)))
 550     (block    (push binding (lexenv-block    lexenv)))
 551     (gotag    (push binding (lexenv-gotag    lexenv)))))
 552
 553 (defun extend-lexenv (bindings lexenv namespace)
 554   (let ((env (copy-lexenv lexenv)))
 555     (dolist (binding (reverse bindings) env)
 556       (push-to-lexenv binding env namespace))))
 557
 558
 559 (defvar *environment* (make-lexenv))
 560
 561 (defvar *variable-counter* 0)
 562
 563 (defun gvarname (symbol)
 564   (code "v" (incf *variable-counter*)))
 565
 566 (defun translate-variable (symbol)
 567   (awhen (lookup-in-lexenv symbol *environment* 'variable)
 568     (binding-value it)))
 569
 570 (defun extend-local-env (args)
 571   (let ((new (copy-lexenv *environment*)))
 572     (dolist (symbol args new)
 573       (let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol))))
 574         (push-to-lexenv b new 'variable)))))
 575
 576 ;;; Toplevel compilations
 577 (defvar *toplevel-compilations* nil)
 578
 579 (defun toplevel-compilation (string)
 580   (push string *toplevel-compilations*))
 581
 582 (defun null-or-empty-p (x)
 583   (zerop (length x)))
 584
 585 (defun get-toplevel-compilations ()
 586   (reverse (remove-if #'null-or-empty-p *toplevel-compilations*)))
 587
 588 (defun %compile-defmacro (name lambda)
 589   (toplevel-compilation (ls-compile `',name))
 590   (let ((binding (make-binding :name name :type 'macro :value lambda)))
 591     (push-to-lexenv binding  *environment* 'function))
 592   name)
 593
 594 (defun global-binding (name type namespace)
 595   (or (lookup-in-lexenv name *environment* namespace)
 596       (let ((b (make-binding :name name :type type :value nil)))
 597         (push-to-lexenv b *environment* namespace)
 598         b)))
 599
 600 (defun claimp (symbol namespace claim)
 601   (let ((b (lookup-in-lexenv symbol *environment* namespace)))
 602     (and b (member claim (binding-declarations b)))))
 603
 604 (defun !proclaim (decl)
 605   (case (car decl)
 606     (special
 607      (dolist (name (cdr decl))
 608        (let ((b (global-binding name 'variable 'variable)))
 609          (push 'special (binding-declarations b)))))
 610     (notinline
 611      (dolist (name (cdr decl))
 612        (let ((b (global-binding name 'function 'function)))
 613          (push 'notinline (binding-declarations b)))))
 614     (constant
 615      (dolist (name (cdr decl))
 616        (let ((b (global-binding name 'variable 'variable)))
 617          (push 'constant (binding-declarations b)))))))
 618
 619 #+ecmalisp
 620 (fset 'proclaim #'!proclaim)
 621
 622 (defun %define-symbol-macro (name expansion)
 623   (let ((b (make-binding :name name :type 'macro :value expansion)))
 624     (push-to-lexenv b *environment* 'variable)
 625     name))
 626
 627 #+ecmalisp
 628 (defmacro define-symbol-macro (name expansion)
 629   `(%define-symbol-macro ',name ',expansion))
 630
 631
 632 ;;; Special forms
 633
 634 (defvar *compilations* nil)
 635
 636 (defmacro define-compilation (name args &body body)
 637   ;; Creates a new primitive `name' with parameters args and
 638   ;; @body. The body can access to the local environment through the
 639   ;; variable *ENVIRONMENT*.
 640   `(push (list ',name (lambda ,args (block ,name ,@body)))
 641          *compilations*))
 642
 643 (define-compilation if (condition true false)
 644   (code "(" (ls-compile condition) " !== " (ls-compile nil)
 645         " ? " (ls-compile true *multiple-value-p*)
 646         " : " (ls-compile false *multiple-value-p*)
 647         ")"))
 648
 649 (defvar *ll-keywords* '(&optional &rest &key))
 650
 651 (defun list-until-keyword (list)
 652   (if (or (null list) (member (car list) *ll-keywords*))
 653       nil
 654       (cons (car list) (list-until-keyword (cdr list)))))
 655
 656 (defun ll-section (keyword ll)
 657   (list-until-keyword (cdr (member keyword ll))))
 658
 659 (defun ll-required-arguments (ll)
 660   (list-until-keyword ll))
 661
 662 (defun ll-optional-arguments-canonical (ll)
 663   (mapcar #'ensure-list (ll-section '&optional ll)))
 664
 665 (defun ll-optional-arguments (ll)
 666   (mapcar #'car (ll-optional-arguments-canonical ll)))
 667
 668 (defun ll-rest-argument (ll)
 669   (let ((rest (ll-section '&rest ll)))
 670     (when (cdr rest)
 671       (error "Bad lambda-list"))
 672     (car rest)))
 673
 674 (defun ll-keyword-arguments-canonical (ll)
 675   (flet ((canonicalize (keyarg)
 676            ;; Build a canonical keyword argument descriptor, filling
 677            ;; the optional fields. The result is a list of the form
 678            ;; ((keyword-name var) init-form).
 679            (let ((arg (ensure-list keyarg)))
 680              (cons (if (listp (car arg))
 681                        (car arg)
 682                        (list (intern (symbol-name (car arg)) "KEYWORD") (car arg)))
 683                    (cdr arg)))))
 684     (mapcar #'canonicalize (ll-section '&key ll))))
 685
 686 (defun ll-keyword-arguments (ll)
 687   (mapcar (lambda (keyarg) (second (first keyarg)))
 688           (ll-keyword-arguments-canonical ll)))
 689
 690 (defun ll-svars (lambda-list)
 691   (let ((args
 692          (append
 693           (ll-keyword-arguments-canonical lambda-list)
 694           (ll-optional-arguments-canonical lambda-list))))
 695     (remove nil (mapcar #'third args))))
 696
 697 (defun lambda-docstring-wrapper (docstring &rest strs)
 698   (if docstring
 699       (js!selfcall
 700         "var func = " (join strs) ";" *newline*
 701         "func.docstring = '" docstring "';" *newline*
 702         "return func;" *newline*)
 703       (apply #'code strs)))
 704
 705 (defun lambda-check-argument-count
 706     (n-required-arguments n-optional-arguments rest-p)
 707   ;; Note: Remember that we assume that the number of arguments of a
 708   ;; call is at least 1 (the values argument).
 709   (let ((min (1+ n-required-arguments))
 710         (max (if rest-p 'n/a (+ 1 n-required-arguments n-optional-arguments))))
 711     (block nil
 712       ;; Special case: a positive exact number of arguments.
 713       (when (and (< 1 min) (eql min max))
 714         (return (code "checkArgs(arguments, " min ");" *newline*)))
 715       ;; General case:
 716       (code
 717        (when (< 1 min)
 718          (code "checkArgsAtLeast(arguments, " min ");" *newline*))
 719        (when (numberp max)
 720          (code "checkArgsAtMost(arguments, " max ");" *newline*))))))
 721
 722 (defun compile-lambda-optional (ll)
 723   (let* ((optional-arguments (ll-optional-arguments-canonical ll))
 724          (n-required-arguments (length (ll-required-arguments ll)))
 725          (n-optional-arguments (length optional-arguments)))
 726     (when optional-arguments
 727       (code (mapconcat (lambda (arg)
 728                          (code "var " (translate-variable (first arg)) "; " *newline*
 729                                (when (third arg)
 730                                  (code "var " (translate-variable (third arg))
 731                                        " = " (ls-compile t)
 732                                        "; " *newline*))))
 733                        optional-arguments)
 734             "switch(arguments.length-1){" *newline*
 735             (let ((cases nil)
 736                   (idx 0))
 737               (progn
 738                 (while (< idx n-optional-arguments)
 739                   (let ((arg (nth idx optional-arguments)))
 740                     (push (code "case " (+ idx n-required-arguments) ":" *newline*
 741                                 (indent (translate-variable (car arg))
 742                                         "="
 743                                         (ls-compile (cadr arg)) ";" *newline*)
 744                                 (when (third arg)
 745                                   (indent (translate-variable (third arg))
 746                                           "="
 747                                           (ls-compile nil)
 748                                           ";" *newline*)))
 749                           cases)
 750                     (incf idx)))
 751                 (push (code "default: break;" *newline*) cases)
 752                 (join (reverse cases))))
 753             "}" *newline*))))
 754
 755 (defun compile-lambda-rest (ll)
 756   (let ((n-required-arguments (length (ll-required-arguments ll)))
 757         (n-optional-arguments (length (ll-optional-arguments ll)))
 758         (rest-argument (ll-rest-argument ll)))
 759     (when rest-argument
 760       (let ((js!rest (translate-variable rest-argument)))
 761         (code "var " js!rest "= " (ls-compile nil) ";" *newline*
 762               "for (var i = arguments.length-1; i>="
 763               (+ 1 n-required-arguments n-optional-arguments)
 764               "; i--)" *newline*
 765               (indent js!rest " = {car: arguments[i], cdr: ") js!rest "};"
 766               *newline*)))))
 767
 768 (defun compile-lambda-parse-keywords (ll)
 769   (let ((n-required-arguments
 770          (length (ll-required-arguments ll)))
 771         (n-optional-arguments
 772          (length (ll-optional-arguments ll)))
 773         (keyword-arguments
 774          (ll-keyword-arguments-canonical ll)))
 775     (code
 776      ;; Declare variables
 777      (mapconcat (lambda (arg)
 778                   (let ((var (second (car arg))))
 779                     (code "var " (translate-variable var) "; " *newline*
 780                           (when (third arg)
 781                             (code "var " (translate-variable (third arg))
 782                                   " = " (ls-compile nil)
 783                                   ";" *newline*)))))
 784                 keyword-arguments)
 785      ;; Parse keywords
 786      (flet ((parse-keyword (keyarg)
 787               ;; ((keyword-name var) init-form)
 788               (code "for (i=" (+ 1 n-required-arguments n-optional-arguments)
 789                     "; i<arguments.length; i+=2){" *newline*
 790                     (indent
 791                      "if (arguments[i] === " (ls-compile (caar keyarg)) "){" *newline*
 792                      (indent (translate-variable (cadr (car keyarg)))
 793                              " = arguments[i+1];"
 794                              *newline*
 795                              (let ((svar (third keyarg)))
 796                                (when svar
 797                                  (code (translate-variable svar) " = " (ls-compile t) ";" *newline*)))
 798                              "break;" *newline*)
 799                      "}" *newline*)
 800                     "}" *newline*
 801                     ;; Default value
 802                     "if (i == arguments.length){" *newline*
 803                     (indent (translate-variable (cadr (car keyarg))) " = " (ls-compile (cadr keyarg)) ";" *newline*)
 804                     "}" *newline*)))
 805        (when keyword-arguments
 806          (code "var i;" *newline*
 807                (mapconcat #'parse-keyword keyword-arguments))))
 808      ;; Check for unknown keywords
 809      (when keyword-arguments
 810        (code "for (i=" (+ 1 n-required-arguments n-optional-arguments)
 811              "; i<arguments.length; i+=2){" *newline*
 812              (indent "if ("
 813                      (join (mapcar (lambda (x)
 814                                      (concat "arguments[i] !== " (ls-compile (caar x))))
 815                                    keyword-arguments)
 816                            " && ")
 817                      ")" *newline*
 818                      (indent
 819                       "throw 'Unknown keyword argument ' + arguments[i].name;" *newline*))
 820              "}" *newline*)))))
 821
 822 (defun compile-lambda (ll body)
 823   (let ((required-arguments (ll-required-arguments ll))
 824         (optional-arguments (ll-optional-arguments ll))
 825         (keyword-arguments  (ll-keyword-arguments  ll))
 826         (rest-argument      (ll-rest-argument      ll))
 827         documentation)
 828     ;; Get the documentation string for the lambda function
 829     (when (and (stringp (car body))
 830                (not (null (cdr body))))
 831       (setq documentation (car body))
 832       (setq body (cdr body)))
 833     (let ((n-required-arguments (length required-arguments))
 834           (n-optional-arguments (length optional-arguments))
 835           (*environment* (extend-local-env
 836                           (append (ensure-list rest-argument)
 837                                   required-arguments
 838                                   optional-arguments
 839                                   keyword-arguments
 840                                   (ll-svars ll)))))
 841       (lambda-docstring-wrapper
 842        documentation
 843        "(function ("
 844        (join (cons "values"
 845                    (mapcar #'translate-variable
 846                            (append required-arguments optional-arguments)))
 847              ",")
 848        "){" *newline*
 849        (indent
 850         ;; Check number of arguments
 851         (lambda-check-argument-count n-required-arguments
 852                                      n-optional-arguments
 853                                      (or rest-argument keyword-arguments))
 854         (compile-lambda-optional ll)
 855         (compile-lambda-rest ll)
 856         (compile-lambda-parse-keywords ll)
 857         (let ((*multiple-value-p* t))
 858           (ls-compile-block body t)))
 859        "})"))))
 860
 861
 862 (defun setq-pair (var val)
 863   (let ((b (lookup-in-lexenv var *environment* 'variable)))
 864     (cond
 865       ((and b
 866             (eq (binding-type b) 'variable)
 867             (not (member 'special (binding-declarations b)))
 868             (not (member 'constant (binding-declarations b))))
 869        (code (binding-value b) " = " (ls-compile val)))
 870       ((and b (eq (binding-type b) 'macro))
 871        (ls-compile `(setf ,var ,val)))
 872       (t
 873        (ls-compile `(set ',var ,val))))))
 874
 875
 876 (define-compilation setq (&rest pairs)
 877   (let ((result ""))
 878     (while t
 879       (cond
 880         ((null pairs) (return))
 881         ((null (cdr pairs))
 882          (error "Odd paris in SETQ"))
 883         (t
 884          (concatf result
 885            (concat (setq-pair (car pairs) (cadr pairs))
 886                    (if (null (cddr pairs)) "" ", ")))
 887          (setq pairs (cddr pairs)))))
 888     (code "(" result ")")))
 889
 890
 891 ;;; Literals
 892 (defun escape-string (string)
 893   (let ((output "")
 894         (index 0)
 895         (size (length string)))
 896     (while (< index size)
 897       (let ((ch (char string index)))
 898         (when (or (char= ch #\") (char= ch #\\))
 899           (setq output (concat output "\\")))
 900         (when (or (char= ch #\newline))
 901           (setq output (concat output "\\"))
 902           (setq ch #\n))
 903         (setq output (concat output (string ch))))
 904       (incf index))
 905     output))
 906
 907
 908 (defvar *literal-symbols* nil)
 909 (defvar *literal-counter* 0)
 910
 911 (defun genlit ()
 912   (code "l" (incf *literal-counter*)))
 913
 914 (defun literal (sexp &optional recursive)
 915   (cond
 916     ((integerp sexp) (integer-to-string sexp))
 917     ((stringp sexp) (code "\"" (escape-string sexp) "\""))
 918     ((symbolp sexp)
 919      (or (cdr (assoc sexp *literal-symbols*))
 920          (let ((v (genlit))
 921                (s #+common-lisp
 922                  (let ((package (symbol-package sexp)))
 923                    (if (eq package (find-package "KEYWORD"))
 924                        (code "{name: \"" (escape-string (symbol-name sexp))
 925                              "\", 'package': '" (package-name package) "'}")
 926                        (code "{name: \"" (escape-string (symbol-name sexp)) "\"}")))
 927                  #+ecmalisp
 928                  (let ((package (symbol-package sexp)))
 929                    (if (null package)
 930                        (code "{name: \"" (escape-string (symbol-name sexp)) "\"}")
 931                        (ls-compile `(intern ,(symbol-name sexp) ,(package-name package)))))))
 932            (push (cons sexp v) *literal-symbols*)
 933            (toplevel-compilation (code "var " v " = " s))
 934            v)))
 935     ((consp sexp)
 936      (let* ((head (butlast sexp))
 937             (tail (last sexp))
 938             (c (code "QIList("
 939                      (join-trailing (mapcar (lambda (x) (literal x t)) head) ",")
 940                      (literal (car tail) t)
 941                      ","
 942                      (literal (cdr tail) t)
 943                      ")")))
 944        (if recursive
 945            c
 946            (let ((v (genlit)))
 947              (toplevel-compilation (code "var " v " = " c))
 948              v))))
 949     ((arrayp sexp)
 950      (let ((elements (vector-to-list sexp)))
 951        (let ((c (concat "[" (join (mapcar #'literal elements) ", ") "]")))
 952          (if recursive
 953              c
 954              (let ((v (genlit)))
 955                (toplevel-compilation (code "var " v " = " c))
 956                v)))))))
 957
 958 (define-compilation quote (sexp)
 959   (literal sexp))
 960
 961 (define-compilation %while (pred &rest body)
 962   (js!selfcall
 963     "while(" (ls-compile pred) " !== " (ls-compile nil) "){" *newline*
 964     (indent (ls-compile-block body))
 965     "}"
 966     "return " (ls-compile nil) ";" *newline*))
 967
 968 (define-compilation function (x)
 969   (cond
 970     ((and (listp x) (eq (car x) 'lambda))
 971      (compile-lambda (cadr x) (cddr x)))
 972     ((symbolp x)
 973      (let ((b (lookup-in-lexenv x *environment* 'function)))
 974        (if b
 975            (binding-value b)
 976            (ls-compile `(symbol-function ',x)))))))
 977
 978
 979 (defun make-function-binding (fname)
 980   (make-binding :name fname :type 'function :value (gvarname fname)))
 981
 982 (defun compile-function-definition (list)
 983   (compile-lambda (car list) (cdr list)))
 984
 985 (defun translate-function (name)
 986   (let ((b (lookup-in-lexenv name *environment* 'function)))
 987     (and b (binding-value b))))
 988
 989 (define-compilation flet (definitions &rest body)
 990   (let* ((fnames (mapcar #'car definitions))
 991          (fbody  (mapcar #'cdr definitions))
 992          (cfuncs (mapcar #'compile-function-definition fbody))
 993          (*environment*
 994           (extend-lexenv (mapcar #'make-function-binding fnames)
 995                          *environment*
 996                          'function)))
 997     (code "(function("
 998           (join (mapcar #'translate-function fnames) ",")
 999           "){" *newline*
1000           (let ((body (ls-compile-block body t)))
1001             (indent body))
1002           "})(" (join cfuncs ",") ")")))
1003
1004 (define-compilation labels (definitions &rest body)
1005   (let* ((fnames (mapcar #'car definitions))
1006          (*environment*
1007           (extend-lexenv (mapcar #'make-function-binding fnames)
1008                          *environment*
1009                          'function)))
1010     (js!selfcall
1011       (mapconcat (lambda (func)
1012                    (code "var " (translate-function (car func))
1013                          " = " (compile-lambda (cadr func) (cddr func))
1014                          ";" *newline*))
1015                  definitions)
1016       (ls-compile-block body t))))
1017
1018
1019 (defvar *compiling-file* nil)
1020 (define-compilation eval-when-compile (&rest body)
1021   (if *compiling-file*
1022       (progn
1023         (eval (cons 'progn body))
1024         nil)
1025       (ls-compile `(progn ,@body))))
1026
1027 (defmacro define-transformation (name args form)
1028   `(define-compilation ,name ,args
1029      (ls-compile ,form)))
1030
1031 (define-compilation progn (&rest body)
1032   (if (null (cdr body))
1033       (ls-compile (car body) *multiple-value-p*)
1034       (js!selfcall (ls-compile-block body t))))
1035
1036 (defun special-variable-p (x)
1037   (and (claimp x 'variable 'special) t))
1038
1039 ;;; Wrap CODE to restore the symbol values of the dynamic
1040 ;;; bindings. BINDINGS is a list of pairs of the form
1041 ;;; (SYMBOL . PLACE),  where PLACE is a Javascript variable
1042 ;;; name to initialize the symbol value and where to stored
1043 ;;; the old value.
1044 (defun let-binding-wrapper (bindings body)
1045   (when (null bindings)
1046     (return-from let-binding-wrapper body))
1047   (code
1048    "try {" *newline*
1049    (indent "var tmp;" *newline*
1050            (mapconcat
1051             (lambda (b)
1052               (let ((s (ls-compile `(quote ,(car b)))))
1053                 (code "tmp = " s ".value;" *newline*
1054                       s ".value = " (cdr b) ";" *newline*
1055                       (cdr b) " = tmp;" *newline*)))
1056             bindings)
1057            body *newline*)
1058    "}" *newline*
1059    "finally {"  *newline*
1060    (indent
1061     (mapconcat (lambda (b)
1062                  (let ((s (ls-compile `(quote ,(car b)))))
1063                    (code s ".value" " = " (cdr b) ";" *newline*)))
1064                bindings))
1065    "}" *newline*))
1066
1067 (define-compilation let (bindings &rest body)
1068   (let* ((bindings (mapcar #'ensure-list bindings))
1069          (variables (mapcar #'first bindings))
1070          (cvalues (mapcar #'ls-compile (mapcar #'second bindings)))
1071          (*environment* (extend-local-env (remove-if #'special-variable-p variables)))
1072          (dynamic-bindings))
1073     (code "(function("
1074           (join (mapcar (lambda (x)
1075                           (if (special-variable-p x)
1076                               (let ((v (gvarname x)))
1077                                 (push (cons x v) dynamic-bindings)
1078                                 v)
1079                               (translate-variable x)))
1080                         variables)
1081                 ",")
1082           "){" *newline*
1083           (let ((body (ls-compile-block body t)))
1084             (indent (let-binding-wrapper dynamic-bindings body)))
1085           "})(" (join cvalues ",") ")")))
1086
1087
1088 ;;; Return the code to initialize BINDING, and push it extending the
1089 ;;; current lexical environment if the variable is not special.
1090 (defun let*-initialize-value (binding)
1091   (let ((var (first binding))
1092         (value (second binding)))
1093     (if (special-variable-p var)
1094         (code (ls-compile `(setq ,var ,value)) ";" *newline*)
1095         (let* ((v (gvarname var))
1096                (b (make-binding :name var :type 'variable :value v)))
1097           (prog1 (code "var " v " = " (ls-compile value) ";" *newline*)
1098             (push-to-lexenv b *environment* 'variable))))))
1099
1100 ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It
1101 ;;; DOES NOT generate code to initialize the value of the symbols,
1102 ;;; unlike let-binding-wrapper.
1103 (defun let*-binding-wrapper (symbols body)
1104   (when (null symbols)
1105     (return-from let*-binding-wrapper body))
1106   (let ((store (mapcar (lambda (s) (cons s (gvarname s)))
1107                        (remove-if-not #'special-variable-p symbols))))
1108     (code
1109      "try {" *newline*
1110      (indent
1111       (mapconcat (lambda (b)
1112                    (let ((s (ls-compile `(quote ,(car b)))))
1113                      (code "var " (cdr b) " = " s ".value;" *newline*)))
1114                  store)
1115       body)
1116      "}" *newline*
1117      "finally {" *newline*
1118      (indent
1119       (mapconcat (lambda (b)
1120                    (let ((s (ls-compile `(quote ,(car b)))))
1121                      (code s ".value" " = " (cdr b) ";" *newline*)))
1122                  store))
1123      "}" *newline*)))
1124
1125 (define-compilation let* (bindings &rest body)
1126   (let ((bindings (mapcar #'ensure-list bindings))
1127         (*environment* (copy-lexenv *environment*)))
1128     (js!selfcall
1129       (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
1130             (body (concat (mapconcat #'let*-initialize-value bindings)
1131                           (ls-compile-block body t))))
1132         (let*-binding-wrapper specials body)))))
1133
1134
1135 (defvar *block-counter* 0)
1136
1137 (define-compilation block (name &rest body)
1138   (let* ((tr (incf *block-counter*))
1139          (b (make-binding :name name :type 'block :value tr)))
1140     (when *multiple-value-p*
1141       (push 'multiple-value (binding-declarations b)))
1142     (let* ((*environment* (extend-lexenv (list b) *environment* 'block))
1143            (cbody (ls-compile-block body t)))
1144       (if (member 'used (binding-declarations b))
1145           (js!selfcall
1146             "try {" *newline*
1147             (indent cbody)
1148             "}" *newline*
1149             "catch (cf){" *newline*
1150             "    if (cf.type == 'block' && cf.id == " tr ")" *newline*
1151             (if *multiple-value-p*
1152                 "        return values.apply(this, forcemv(cf.values));"
1153                 "        return cf.values;")
1154             *newline*
1155             "    else" *newline*
1156             "        throw cf;" *newline*
1157             "}" *newline*)
1158           (js!selfcall cbody)))))
1159
1160 (define-compilation return-from (name &optional value)
1161   (let* ((b (lookup-in-lexenv name *environment* 'block))
1162          (multiple-value-p (member 'multiple-value (binding-declarations b))))
1163     (when (null b)
1164       (error (concat "Unknown block `" (symbol-name name) "'.")))
1165     (push 'used (binding-declarations b))
1166     (js!selfcall
1167       (when multiple-value-p (code "var values = mv;" *newline*))
1168       "throw ({"
1169       "type: 'block', "
1170       "id: " (binding-value b) ", "
1171       "values: " (ls-compile value multiple-value-p) ", "
1172       "message: 'Return from unknown block " (symbol-name name) ".'"
1173       "})")))
1174
1175 (define-compilation catch (id &rest body)
1176   (js!selfcall
1177     "var id = " (ls-compile id) ";" *newline*
1178     "try {" *newline*
1179     (indent (ls-compile-block body t)) *newline*
1180     "}" *newline*
1181     "catch (cf){" *newline*
1182     "    if (cf.type == 'catch' && cf.id == id)" *newline*
1183     (if *multiple-value-p*
1184         "        return values.apply(this, forcemv(cf.values));"
1185         "        return pv.apply(this, forcemv(cf.values));")
1186     *newline*
1187     "    else" *newline*
1188     "        throw cf;" *newline*
1189     "}" *newline*))
1190
1191 (define-compilation throw (id value)
1192   (js!selfcall
1193     "var values = mv;" *newline*
1194     "throw ({"
1195     "type: 'catch', "
1196     "id: " (ls-compile id) ", "
1197     "values: " (ls-compile value t) ", "
1198     "message: 'Throw uncatched.'"
1199     "})"))
1200
1201
1202 (defvar *tagbody-counter* 0)
1203 (defvar *go-tag-counter* 0)
1204
1205 (defun go-tag-p (x)
1206   (or (integerp x) (symbolp x)))
1207
1208 (defun declare-tagbody-tags (tbidx body)
1209   (let ((bindings
1210          (mapcar (lambda (label)
1211                    (let ((tagidx (integer-to-string (incf *go-tag-counter*))))
1212                      (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
1213                  (remove-if-not #'go-tag-p body))))
1214     (extend-lexenv bindings *environment* 'gotag)))
1215
1216 (define-compilation tagbody (&rest body)
1217   ;; Ignore the tagbody if it does not contain any go-tag. We do this
1218   ;; because 1) it is easy and 2) many built-in forms expand to a
1219   ;; implicit tagbody, so we save some space.
1220   (unless (some #'go-tag-p body)
1221     (return-from tagbody (ls-compile `(progn ,@body nil))))
1222   ;; The translation assumes the first form in BODY is a label
1223   (unless (go-tag-p (car body))
1224     (push (gensym "START") body))
1225   ;; Tagbody compilation
1226   (let ((tbidx *tagbody-counter*))
1227     (let ((*environment* (declare-tagbody-tags tbidx body))
1228           initag)
1229       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
1230         (setq initag (second (binding-value b))))
1231       (js!selfcall
1232         "var tagbody_" tbidx " = " initag ";" *newline*
1233         "tbloop:" *newline*
1234         "while (true) {" *newline*
1235         (indent "try {" *newline*
1236                 (indent (let ((content ""))
1237                           (code "switch(tagbody_" tbidx "){" *newline*
1238                                 "case " initag ":" *newline*
1239                                 (dolist (form (cdr body) content)
1240                                   (concatf content
1241                                     (if (not (go-tag-p form))
1242                                         (indent (ls-compile form) ";" *newline*)
1243                                         (let ((b (lookup-in-lexenv form *environment* 'gotag)))
1244                                           (code "case " (second (binding-value b)) ":" *newline*)))))
1245                                 "default:" *newline*
1246                                 "    break tbloop;" *newline*
1247                                 "}" *newline*)))
1248                 "}" *newline*
1249                 "catch (jump) {" *newline*
1250                 "    if (jump.type == 'tagbody' && jump.id == " tbidx ")" *newline*
1251                 "        tagbody_" tbidx " = jump.label;" *newline*
1252                 "    else" *newline*
1253                 "        throw(jump);" *newline*
1254                 "}" *newline*)
1255         "}" *newline*
1256         "return " (ls-compile nil) ";" *newline*))))
1257
1258 (define-compilation go (label)
1259   (let ((b (lookup-in-lexenv label *environment* 'gotag))
1260         (n (cond
1261              ((symbolp label) (symbol-name label))
1262              ((integerp label) (integer-to-string label)))))
1263     (when (null b)
1264       (error (concat "Unknown tag `" n "'.")))
1265     (js!selfcall
1266       "throw ({"
1267       "type: 'tagbody', "
1268       "id: " (first (binding-value b)) ", "
1269       "label: " (second (binding-value b)) ", "
1270       "message: 'Attempt to GO to non-existing tag " n "'"
1271       "})" *newline*)))
1272
1273 (define-compilation unwind-protect (form &rest clean-up)
1274   (js!selfcall
1275     "var ret = " (ls-compile nil) ";" *newline*
1276     "try {" *newline*
1277     (indent "ret = " (ls-compile form) ";" *newline*)
1278     "} finally {" *newline*
1279     (indent (ls-compile-block clean-up))
1280     "}" *newline*
1281     "return ret;" *newline*))
1282
1283 (define-compilation multiple-value-call (func-form &rest forms)
1284   (js!selfcall
1285     "var func = " (ls-compile func-form) ";" *newline*
1286     "var args = [" (if *multiple-value-p* "values" "pv") "];" *newline*
1287     "return "
1288     (js!selfcall
1289       "var values = mv;" *newline*
1290       "var vs;" *newline*
1291       (mapconcat (lambda (form)
1292                    (code "vs = " (ls-compile form t) ";" *newline*
1293                          "if (typeof vs === 'object' && 'multiple-value' in vs)" *newline*
1294                          (indent "args = args.concat(vs);" *newline*)
1295                          "else" *newline*
1296                          (indent "args.push(vs);" *newline*)))
1297                  forms)
1298       "return func.apply(window, args);" *newline*) ";" *newline*))
1299
1300 (define-compilation multiple-value-prog1 (first-form &rest forms)
1301   (js!selfcall
1302     "var args = " (ls-compile first-form *multiple-value-p*) ";" *newline*
1303     (ls-compile-block forms)
1304     "return args;" *newline*))
1305
1306
1307 ;;; Javascript FFI
1308
1309 (define-compilation %js-vref (var) var)
1310
1311 (define-compilation %js-vset (var val)
1312   (code "(" var " = " (ls-compile val) ")"))
1313
1314 (define-setf-expander %js-vref (var)
1315   (let ((new-value (gensym)))
1316     (unless (stringp var)
1317       (error "a string was expected"))
1318     (values nil
1319             (list var)
1320             (list new-value)
1321             `(%js-vset ,var ,new-value)
1322             `(%js-vref ,var))))
1323
1324
1325 ;;; Backquote implementation.
1326 ;;;
1327 ;;;    Author: Guy L. Steele Jr.     Date: 27 December 1985
1328 ;;;    Tested under Symbolics Common Lisp and Lucid Common Lisp.
1329 ;;;    This software is in the public domain.
1330
1331 ;;;    The following are unique tokens used during processing.
1332 ;;;    They need not be symbols; they need not even be atoms.
1333 (defvar *comma* 'unquote)
1334 (defvar *comma-atsign* 'unquote-splicing)
1335
1336 (defvar *bq-list* (make-symbol "BQ-LIST"))
1337 (defvar *bq-append* (make-symbol "BQ-APPEND"))
1338 (defvar *bq-list** (make-symbol "BQ-LIST*"))
1339 (defvar *bq-nconc* (make-symbol "BQ-NCONC"))
1340 (defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
1341 (defvar *bq-quote* (make-symbol "BQ-QUOTE"))
1342 (defvar *bq-quote-nil* (list *bq-quote* nil))
1343
1344 ;;; BACKQUOTE is an ordinary macro (not a read-macro) that processes
1345 ;;; the expression foo, looking for occurrences of #:COMMA,
1346 ;;; #:COMMA-ATSIGN, and #:COMMA-DOT.  It constructs code in strict
1347 ;;; accordance with the rules on pages 349-350 of the first edition
1348 ;;; (pages 528-529 of this second edition).  It then optionally
1349 ;;; applies a code simplifier.
1350
1351 ;;; If the value of *BQ-SIMPLIFY* is non-NIL, then BACKQUOTE
1352 ;;; processing applies the code simplifier.  If the value is NIL,
1353 ;;; then the code resulting from BACKQUOTE is exactly that
1354 ;;; specified by the official rules.
1355 (defparameter *bq-simplify* t)
1356
1357 (defmacro backquote (x)
1358   (bq-completely-process x))
1359
1360 ;;; Backquote processing proceeds in three stages:
1361 ;;;
1362 ;;; (1) BQ-PROCESS applies the rules to remove occurrences of
1363 ;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to
1364 ;;; this level of BACKQUOTE.  (It also causes embedded calls to
1365 ;;; BACKQUOTE to be expanded so that nesting is properly handled.)
1366 ;;; Code is produced that is expressed in terms of functions
1367 ;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE.  This is done
1368 ;;; so that the simplifier will simplify only list construction
1369 ;;; functions actually generated by BACKQUOTE and will not involve
1370 ;;; any user code in the simplification.  #:BQ-LIST means LIST,
1371 ;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY
1372 ;;; but indicates places where "%." was used and where NCONC may
1373 ;;; therefore be introduced by the simplifier for efficiency.
1374 ;;;
1375 ;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by
1376 ;;; BQ-PROCESS to produce equivalent but faster code.  The
1377 ;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be
1378 ;;; introduced into the code.
1379 ;;;
1380 ;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces
1381 ;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on.
1382 ;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being
1383 ;;; replaced by its argument).  #:BQ-LIST* is replaced by either
1384 ;;; LIST* or CONS (the latter is used in the two-argument case,
1385 ;;; purely to make the resulting code a tad more readable).
1386
1387 (defun bq-completely-process (x)
1388   (let ((raw-result (bq-process x)))
1389     (bq-remove-tokens (if *bq-simplify*
1390                           (bq-simplify raw-result)
1391                           raw-result))))
1392
1393 (defun bq-process (x)
1394   (cond ((atom x)
1395          (list *bq-quote* x))
1396         ((eq (car x) 'backquote)
1397          (bq-process (bq-completely-process (cadr x))))
1398         ((eq (car x) *comma*) (cadr x))
1399         ((eq (car x) *comma-atsign*)
1400          ;; (error ",@~S after `" (cadr x))
1401          (error "ill-formed"))
1402         ;; ((eq (car x) *comma-dot*)
1403         ;;  ;; (error ",.~S after `" (cadr x))
1404         ;;  (error "ill-formed"))
1405         (t (do ((p x (cdr p))
1406                 (q '() (cons (bracket (car p)) q)))
1407                ((atom p)
1408                 (cons *bq-append*
1409                       (nreconc q (list (list *bq-quote* p)))))
1410              (when (eq (car p) *comma*)
1411                (unless (null (cddr p))
1412                  ;; (error "Malformed ,~S" p)
1413                  (error "Malformed"))
1414                (return (cons *bq-append*
1415                              (nreconc q (list (cadr p))))))
1416              (when (eq (car p) *comma-atsign*)
1417                ;; (error "Dotted ,@~S" p)
1418                (error "Dotted"))
1419              ;; (when (eq (car p) *comma-dot*)
1420              ;;   ;; (error "Dotted ,.~S" p)
1421              ;;   (error "Dotted"))
1422              ))))
1423
1424 ;;; This implements the bracket operator of the formal rules.
1425 (defun bracket (x)
1426   (cond ((atom x)
1427          (list *bq-list* (bq-process x)))
1428         ((eq (car x) *comma*)
1429          (list *bq-list* (cadr x)))
1430         ((eq (car x) *comma-atsign*)
1431          (cadr x))
1432         ;; ((eq (car x) *comma-dot*)
1433         ;;  (list *bq-clobberable* (cadr x)))
1434         (t (list *bq-list* (bq-process x)))))
1435
1436 ;;; This auxiliary function is like MAPCAR but has two extra
1437 ;;; purposes: (1) it handles dotted lists; (2) it tries to make
1438 ;;; the result share with the argument x as much as possible.
1439 (defun maptree (fn x)
1440   (if (atom x)
1441       (funcall fn x)
1442       (let ((a (funcall fn (car x)))
1443             (d (maptree fn (cdr x))))
1444         (if (and (eql a (car x)) (eql d (cdr x)))
1445             x
1446             (cons a d)))))
1447
1448 ;;; This predicate is true of a form that when read looked
1449 ;;; like %@foo or %.foo.
1450 (defun bq-splicing-frob (x)
1451   (and (consp x)
1452        (or (eq (car x) *comma-atsign*)
1453            ;; (eq (car x) *comma-dot*)
1454            )))
1455
1456 ;;; This predicate is true of a form that when read
1457 ;;; looked like %@foo or %.foo or just plain %foo.
1458 (defun bq-frob (x)
1459   (and (consp x)
1460        (or (eq (car x) *comma*)
1461            (eq (car x) *comma-atsign*)
1462            ;; (eq (car x) *comma-dot*)
1463            )))
1464
1465 ;;; The simplifier essentially looks for calls to #:BQ-APPEND and
1466 ;;; tries to simplify them.  The arguments to #:BQ-APPEND are
1467 ;;; processed from right to left, building up a replacement form.
1468 ;;; At each step a number of special cases are handled that,
1469 ;;; loosely speaking, look like this:
1470 ;;;
1471 ;;;  (APPEND (LIST a b c) foo) => (LIST* a b c foo)
1472 ;;;       provided a, b, c are not splicing frobs
1473 ;;;  (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo))
1474 ;;;       provided a, b, c are not splicing frobs
1475 ;;;  (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo)
1476 ;;;  (APPEND (CLOBBERABLE x) foo) => (NCONC x foo)
1477 (defun bq-simplify (x)
1478   (if (atom x)
1479       x
1480       (let ((x (if (eq (car x) *bq-quote*)
1481                    x
1482                    (maptree #'bq-simplify x))))
1483         (if (not (eq (car x) *bq-append*))
1484             x
1485             (bq-simplify-args x)))))
1486
1487 (defun bq-simplify-args (x)
1488   (do ((args (reverse (cdr x)) (cdr args))
1489        (result
1490          nil
1491          (cond ((atom (car args))
1492                 (bq-attach-append *bq-append* (car args) result))
1493                ((and (eq (caar args) *bq-list*)
1494                      (notany #'bq-splicing-frob (cdar args)))
1495                 (bq-attach-conses (cdar args) result))
1496                ((and (eq (caar args) *bq-list**)
1497                      (notany #'bq-splicing-frob (cdar args)))
1498                 (bq-attach-conses
1499                   (reverse (cdr (reverse (cdar args))))
1500                   (bq-attach-append *bq-append*
1501                                     (car (last (car args)))
1502                                     result)))
1503                ((and (eq (caar args) *bq-quote*)
1504                      (consp (cadar args))
1505                      (not (bq-frob (cadar args)))
1506                      (null (cddar args)))
1507                 (bq-attach-conses (list (list *bq-quote*
1508                                               (caadar args)))
1509                                   result))
1510                ((eq (caar args) *bq-clobberable*)
1511                 (bq-attach-append *bq-nconc* (cadar args) result))
1512                (t (bq-attach-append *bq-append*
1513                                     (car args)
1514                                     result)))))
1515       ((null args) result)))
1516
1517 (defun null-or-quoted (x)
1518   (or (null x) (and (consp x) (eq (car x) *bq-quote*))))
1519
1520 ;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND
1521 ;;; or #:BQ-NCONC.  This produces a form (op item result) but
1522 ;;; some simplifications are done on the fly:
1523 ;;;
1524 ;;;  (op '(a b c) '(d e f g)) => '(a b c d e f g)
1525 ;;;  (op item 'nil) => item, provided item is not a splicable frob
1526 ;;;  (op item 'nil) => (op item), if item is a splicable frob
1527 ;;;  (op item (op a b c)) => (op item a b c)
1528 (defun bq-attach-append (op item result)
1529   (cond ((and (null-or-quoted item) (null-or-quoted result))
1530          (list *bq-quote* (append (cadr item) (cadr result))))
1531         ((or (null result) (equal result *bq-quote-nil*))
1532          (if (bq-splicing-frob item) (list op item) item))
1533         ((and (consp result) (eq (car result) op))
1534          (list* (car result) item (cdr result)))
1535         (t (list op item result))))
1536
1537 ;;; The effect of BQ-ATTACH-CONSES is to produce a form as if by
1538 ;;; `(LIST* ,@items ,result) but some simplifications are done
1539 ;;; on the fly.
1540 ;;;
1541 ;;;  (LIST* 'a 'b 'c 'd) => '(a b c . d)
1542 ;;;  (LIST* a b c 'nil) => (LIST a b c)
1543 ;;;  (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g)
1544 ;;;  (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g)
1545 (defun bq-attach-conses (items result)
1546   (cond ((and (every #'null-or-quoted items)
1547               (null-or-quoted result))
1548          (list *bq-quote*
1549                (append (mapcar #'cadr items) (cadr result))))
1550         ((or (null result) (equal result *bq-quote-nil*))
1551          (cons *bq-list* items))
1552         ((and (consp result)
1553               (or (eq (car result) *bq-list*)
1554                   (eq (car result) *bq-list**)))
1555          (cons (car result) (append items (cdr result))))
1556         (t (cons *bq-list** (append items (list result))))))
1557
1558 ;;; Removes funny tokens and changes (#:BQ-LIST* a b) into
1559 ;;; (CONS a b) instead of (LIST* a b), purely for readability.
1560 (defun bq-remove-tokens (x)
1561   (cond ((eq x *bq-list*) 'list)
1562         ((eq x *bq-append*) 'append)
1563         ((eq x *bq-nconc*) 'nconc)
1564         ((eq x *bq-list**) 'list*)
1565         ((eq x *bq-quote*) 'quote)
1566         ((atom x) x)
1567         ((eq (car x) *bq-clobberable*)
1568          (bq-remove-tokens (cadr x)))
1569         ((and (eq (car x) *bq-list**)
1570               (consp (cddr x))
1571               (null (cdddr x)))
1572          (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
1573         (t (maptree #'bq-remove-tokens x))))
1574
1575 (define-transformation backquote (form)
1576   (bq-completely-process form))
1577
1578
1579 ;;; Primitives
1580
1581 (defvar *builtins* nil)
1582
1583 (defmacro define-raw-builtin (name args &body body)
1584   ;; Creates a new primitive function `name' with parameters args and
1585   ;; @body. The body can access to the local environment through the
1586   ;; variable *ENVIRONMENT*.
1587   `(push (list ',name (lambda ,args (block ,name ,@body)))
1588          *builtins*))
1589
1590 (defmacro define-builtin (name args &body body)
1591   `(define-raw-builtin ,name ,args
1592      (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)
1593        ,@body)))
1594
1595 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
1596 (defmacro type-check (decls &body body)
1597   `(js!selfcall
1598      ,@(mapcar (lambda (decl)
1599                  `(code "var " ,(first decl) " = " ,(third decl) ";" *newline*))
1600                decls)
1601      ,@(mapcar (lambda (decl)
1602                  `(code "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline*
1603                         (indent "throw 'The value ' + "
1604                                 ,(first decl)
1605                                 " + ' is not a type "
1606                                 ,(second decl)
1607                                 ".';"
1608                                 *newline*)))
1609                decls)
1610      (code "return " (progn ,@body) ";" *newline*)))
1611
1612 ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
1613 ;;; a variable which holds a list of forms. It will compile them and
1614 ;;; store the result in some Javascript variables. BODY is evaluated
1615 ;;; with ARGS bound to the list of these variables to generate the
1616 ;;; code which performs the transformation on these variables.
1617
1618 (defun variable-arity-call (args function)
1619   (unless (consp args)
1620     (error "ARGS must be a non-empty list"))
1621   (let ((counter 0)
1622         (fargs '())
1623         (prelude ""))
1624     (dolist (x args)
1625       (if (numberp x)
1626           (push (integer-to-string x) fargs)
1627           (let ((v (code "x" (incf counter))))
1628             (push v fargs)
1629             (concatf prelude
1630               (code "var " v " = " (ls-compile x) ";" *newline*
1631                     "if (typeof " v " !== 'number') throw 'Not a number!';"
1632                     *newline*)))))
1633     (js!selfcall prelude (funcall function (reverse fargs)))))
1634
1635
1636 (defmacro variable-arity (args &body body)
1637   (unless (symbolp args)
1638     (error "Bad usage of VARIABLE-ARITY, you must pass a symbol"))
1639   `(variable-arity-call ,args
1640                         (lambda (,args)
1641                           (code "return " ,@body ";" *newline*))))
1642
1643 (defun num-op-num (x op y)
1644   (type-check (("x" "number" x) ("y" "number" y))
1645     (code "x" op "y")))
1646
1647 (define-raw-builtin + (&rest numbers)
1648   (if (null numbers)
1649       "0"
1650       (variable-arity numbers
1651         (join numbers "+"))))
1652
1653 (define-raw-builtin - (x &rest others)
1654   (let ((args (cons x others)))
1655     (variable-arity args
1656       (if (null others)
1657           (concat "-" (car args))
1658           (join args "-")))))
1659
1660 (define-raw-builtin * (&rest numbers)
1661   (if (null numbers)
1662       "1"
1663       (variable-arity numbers
1664         (join numbers "*"))))
1665
1666 (define-raw-builtin / (x &rest others)
1667   (let ((args (cons x others)))
1668     (variable-arity args
1669       (if (null others)
1670           (concat "1 /" (car args))
1671           (join args "/")))))
1672
1673 (define-builtin mod (x y) (num-op-num x "%" y))
1674
1675
1676 (defun comparison-conjuntion (vars op)
1677   (cond
1678     ((null (cdr vars))
1679      "true")
1680     ((null (cddr vars))
1681      (concat (car vars) op (cadr vars)))
1682     (t
1683      (concat (car vars) op (cadr vars)
1684              " && "
1685              (comparison-conjuntion (cdr vars) op)))))
1686
1687 (defmacro define-builtin-comparison (op sym)
1688   `(define-raw-builtin ,op (x &rest args)
1689      (let ((args (cons x args)))
1690        (variable-arity args
1691          (js!bool (comparison-conjuntion args ,sym))))))
1692
1693 (define-builtin-comparison > ">")
1694 (define-builtin-comparison < "<")
1695 (define-builtin-comparison >= ">=")
1696 (define-builtin-comparison <= "<=")
1697 (define-builtin-comparison = "==")
1698
1699 (define-builtin numberp (x)
1700   (js!bool (code "(typeof (" x ") == \"number\")")))
1701
1702 (define-builtin floor (x)
1703   (type-check (("x" "number" x))
1704     "Math.floor(x)"))
1705
1706 (define-builtin cons (x y)
1707   (code "({car: " x ", cdr: " y "})"))
1708
1709 (define-builtin consp (x)
1710   (js!bool
1711    (js!selfcall
1712      "var tmp = " x ";" *newline*
1713      "return (typeof tmp == 'object' && 'car' in tmp);" *newline*)))
1714
1715 (define-builtin car (x)
1716   (js!selfcall
1717     "var tmp = " x ";" *newline*
1718     "return tmp === " (ls-compile nil)
1719     "? " (ls-compile nil)
1720     ": tmp.car;" *newline*))
1721
1722 (define-builtin cdr (x)
1723   (js!selfcall
1724     "var tmp = " x ";" *newline*
1725     "return tmp === " (ls-compile nil) "? "
1726     (ls-compile nil)
1727     ": tmp.cdr;" *newline*))
1728
1729 (define-builtin rplaca (x new)
1730   (type-check (("x" "object" x))
1731     (code "(x.car = " new ", x)")))
1732
1733 (define-builtin rplacd (x new)
1734   (type-check (("x" "object" x))
1735     (code "(x.cdr = " new ", x)")))
1736
1737 (define-builtin symbolp (x)
1738   (js!bool
1739    (js!selfcall
1740      "var tmp = " x ";" *newline*
1741      "return (typeof tmp == 'object' && 'name' in tmp);" *newline*)))
1742
1743 (define-builtin make-symbol (name)
1744   (type-check (("name" "string" name))
1745     "({name: name})"))
1746
1747 (define-builtin symbol-name (x)
1748   (code "(" x ").name"))
1749
1750 (define-builtin set (symbol value)
1751   (code "(" symbol ").value = " value))
1752
1753 (define-builtin fset (symbol value)
1754   (code "(" symbol ").fvalue = " value))
1755
1756 (define-builtin boundp (x)
1757   (js!bool (code "(" x ".value !== undefined)")))
1758
1759 (define-builtin symbol-value (x)
1760   (js!selfcall
1761     "var symbol = " x ";" *newline*
1762     "var value = symbol.value;" *newline*
1763     "if (value === undefined) throw \"Variable `\" + symbol.name + \"' is unbound.\";" *newline*
1764     "return value;" *newline*))
1765
1766 (define-builtin symbol-function (x)
1767   (js!selfcall
1768     "var symbol = " x ";" *newline*
1769     "var func = symbol.fvalue;" *newline*
1770     "if (func === undefined) throw \"Function `\" + symbol.name + \"' is undefined.\";" *newline*
1771     "return func;" *newline*))
1772
1773 (define-builtin symbol-plist (x)
1774   (code "((" x ").plist || " (ls-compile nil) ")"))
1775
1776 (define-builtin lambda-code (x)
1777   (code "(" x ").toString()"))
1778
1779 (define-builtin eq    (x y) (js!bool (code "(" x " === " y ")")))
1780 (define-builtin equal (x y) (js!bool (code "(" x  " == " y ")")))
1781
1782 (define-builtin char-to-string (x)
1783   (type-check (("x" "number" x))
1784     "String.fromCharCode(x)"))
1785
1786 (define-builtin stringp (x)
1787   (js!bool (code "(typeof(" x ") == \"string\")")))
1788
1789 (define-builtin string-upcase (x)
1790   (type-check (("x" "string" x))
1791     "x.toUpperCase()"))
1792
1793 (define-builtin string-length (x)
1794   (type-check (("x" "string" x))
1795     "x.length"))
1796
1797 (define-raw-builtin slice (string a &optional b)
1798   (js!selfcall
1799     "var str = " (ls-compile string) ";" *newline*
1800     "var a = " (ls-compile a) ";" *newline*
1801     "var b;" *newline*
1802     (when b (code "b = " (ls-compile b) ";" *newline*))
1803     "return str.slice(a,b);" *newline*))
1804
1805 (define-builtin char (string index)
1806   (type-check (("string" "string" string)
1807                ("index" "number" index))
1808     "string.charCodeAt(index)"))
1809
1810 (define-builtin concat-two (string1 string2)
1811   (type-check (("string1" "string" string1)
1812                ("string2" "string" string2))
1813     "string1.concat(string2)"))
1814
1815 (define-raw-builtin funcall (func &rest args)
1816   (js!selfcall
1817     "var f = " (ls-compile func) ";" *newline*
1818     "return (typeof f === 'function'? f: f.fvalue)("
1819     (join (cons (if *multiple-value-p* "values" "pv")
1820                 (mapcar #'ls-compile args))
1821           ", ")
1822     ")"))
1823
1824 (define-raw-builtin apply (func &rest args)
1825   (if (null args)
1826       (code "(" (ls-compile func) ")()")
1827       (let ((args (butlast args))
1828             (last (car (last args))))
1829         (js!selfcall
1830           "var f = " (ls-compile func) ";" *newline*
1831           "var args = [" (join (cons (if *multiple-value-p* "values" "pv")
1832                                      (mapcar #'ls-compile args))
1833                                ", ")
1834           "];" *newline*
1835           "var tail = (" (ls-compile last) ");" *newline*
1836           "while (tail != " (ls-compile nil) "){" *newline*
1837           "    args.push(tail.car);" *newline*
1838           "    tail = tail.cdr;" *newline*
1839           "}" *newline*
1840           "return (typeof f === 'function'? f : f.fvalue).apply(this, args);" *newline*))))
1841
1842 (define-builtin js-eval (string)
1843   (type-check (("string" "string" string))
1844     (if *multiple-value-p*
1845         (js!selfcall
1846           "var v = eval.apply(window, [string]);" *newline*
1847           "if (typeof v !== 'object' || !('multiple-value' in v)){" *newline*
1848           (indent "v = [v];" *newline*
1849                   "v['multiple-value'] = true;" *newline*)
1850           "}" *newline*
1851           "return values.apply(this, v);" *newline*)
1852         "eval.apply(window, [string])")))
1853
1854 (define-builtin error (string)
1855   (js!selfcall "throw " string ";" *newline*))
1856
1857 (define-builtin new () "{}")
1858
1859 (define-builtin objectp (x)
1860   (js!bool (code "(typeof (" x ") === 'object')")))
1861
1862 (define-builtin oget (object key)
1863   (js!selfcall
1864     "var tmp = " "(" object ")[" key "];" *newline*
1865     "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))
1866
1867 (define-builtin oset (object key value)
1868   (code "((" object ")[" key "] = " value ")"))
1869
1870 (define-builtin in (key object)
1871   (js!bool (code "((" key ") in (" object "))")))
1872
1873 (define-builtin functionp (x)
1874   (js!bool (code "(typeof " x " == 'function')")))
1875
1876 (define-builtin write-string (x)
1877   (type-check (("x" "string" x))
1878     "lisp.write(x)"))
1879
1880 (define-builtin make-array (n)
1881   (js!selfcall
1882     "var r = [];" *newline*
1883     "for (var i = 0; i < " n "; i++)" *newline*
1884     (indent "r.push(" (ls-compile nil) ");" *newline*)
1885     "return r;" *newline*))
1886
1887 (define-builtin arrayp (x)
1888   (js!bool
1889    (js!selfcall
1890      "var x = " x ";" *newline*
1891      "return typeof x === 'object' && 'length' in x;")))
1892
1893 (define-builtin aref (array n)
1894   (js!selfcall
1895     "var x = " "(" array ")[" n "];" *newline*
1896     "if (x === undefined) throw 'Out of range';" *newline*
1897     "return x;" *newline*))
1898
1899 (define-builtin aset (array n value)
1900   (js!selfcall
1901     "var x = " array ";" *newline*
1902     "var i = " n ";" *newline*
1903     "if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
1904     "return x[i] = " value ";" *newline*))
1905
1906 (define-builtin get-unix-time ()
1907   (code "(Math.round(new Date() / 1000))"))
1908
1909 (define-builtin values-array (array)
1910   (if *multiple-value-p*
1911       (code "values.apply(this, " array ")")
1912       (code "pv.apply(this, " array ")")))
1913
1914 (define-raw-builtin values (&rest args)
1915   (if *multiple-value-p*
1916       (code "values(" (join (mapcar #'ls-compile args) ", ") ")")
1917       (code "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
1918
1919 ;; Receives the JS function as first argument as a literal string. The
1920 ;; second argument is compiled and should evaluate to a vector of
1921 ;; values to apply to the the function. The result returned.
1922 (define-builtin %js-call (fun args)
1923   (code fun ".apply(this, " args ")"))
1924
1925 (defun macro (x)
1926   (and (symbolp x)
1927        (let ((b (lookup-in-lexenv x *environment* 'function)))
1928          (if (and b (eq (binding-type b) 'macro))
1929              b
1930              nil))))
1931
1932 #+common-lisp
1933 (defvar *macroexpander-cache*
1934   (make-hash-table :test #'eq))
1935
1936 (defun ls-macroexpand-1 (form)
1937   (cond
1938     ((symbolp form)
1939      (let ((b (lookup-in-lexenv form *environment* 'variable)))
1940        (if (and b (eq (binding-type b) 'macro))
1941            (values (binding-value b) t)
1942            (values form nil))))
1943     ((consp form)
1944      (let ((macro-binding (macro (car form))))
1945        (if macro-binding
1946            (let ((expander (binding-value macro-binding)))
1947              (cond
1948                #+common-lisp
1949                ((gethash macro-binding *macroexpander-cache*)
1950                 (setq expander (gethash macro-binding *macroexpander-cache*)))
1951                ((listp expander)
1952                 (let ((compiled (eval expander)))
1953                   ;; The list representation are useful while
1954                   ;; bootstrapping, as we can dump the definition of the
1955                   ;; macros easily, but they are slow because we have to
1956                   ;; evaluate them and compile them now and again. So, let
1957                   ;; us replace the list representation version of the
1958                   ;; function with the compiled one.
1959                   ;;
1960                   #+ecmalisp (setf (binding-value macro-binding) compiled)
1961                   #+common-lisp (setf (gethash macro-binding *macroexpander-cache*) compiled)
1962                   (setq expander compiled))))
1963              (values (apply expander (cdr form)) t))
1964            (values form nil))))
1965     (t
1966      (values form nil))))
1967
1968 (defun compile-funcall (function args)
1969   (let* ((values-funcs (if *multiple-value-p* "values" "pv"))
1970          (arglist (concat "(" (join (cons values-funcs (mapcar #'ls-compile args)) ", ") ")")))
1971     (cond
1972       ((translate-function function)
1973        (concat (translate-function function) arglist))
1974       ((and (symbolp function)
1975             #+ecmalisp (eq (symbol-package function) (find-package "COMMON-LISP"))
1976             #+common-lisp t)
1977        (code (ls-compile `',function) ".fvalue" arglist))
1978       (t
1979        (code (ls-compile `#',function) arglist)))))
1980
1981 (defun ls-compile-block (sexps &optional return-last-p)
1982   (if return-last-p
1983       (code (ls-compile-block (butlast sexps))
1984             "return " (ls-compile (car (last sexps)) *multiple-value-p*) ";")
1985       (join-trailing
1986        (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
1987        (concat ";" *newline*))))
1988
1989 (defun ls-compile (sexp &optional multiple-value-p)
1990   (multiple-value-bind (sexp expandedp) (ls-macroexpand-1 sexp)
1991     (when expandedp
1992       (return-from ls-compile (ls-compile sexp multiple-value-p)))
1993     ;; The expression has been macroexpanded. Now compile it!
1994     (let ((*multiple-value-p* multiple-value-p))
1995       (cond
1996         ((symbolp sexp)
1997          (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
1998            (cond
1999              ((and b (not (member 'special (binding-declarations b))))
2000               (binding-value b))
2001              ((or (keywordp sexp)
2002                   (and b (member 'constant (binding-declarations b))))
2003               (code (ls-compile `',sexp) ".value"))
2004              (t
2005               (ls-compile `(symbol-value ',sexp))))))
2006         ((integerp sexp) (integer-to-string sexp))
2007         ((stringp sexp) (code "\"" (escape-string sexp) "\""))
2008         ((arrayp sexp) (literal sexp))
2009         ((listp sexp)
2010          (let ((name (car sexp))
2011                (args (cdr sexp)))
2012            (cond
2013              ;; Special forms
2014              ((assoc name *compilations*)
2015               (let ((comp (second (assoc name *compilations*))))
2016                 (apply comp args)))
2017              ;; Built-in functions
2018              ((and (assoc name *builtins*)
2019                    (not (claimp name 'function 'notinline)))
2020               (let ((comp (second (assoc name *builtins*))))
2021                 (apply comp args)))
2022              (t
2023               (compile-funcall name args)))))
2024         (t
2025          (error (concat "How should I compile " (prin1-to-string sexp) "?")))))))
2026
2027
2028 (defvar *compile-print-toplevels* nil)
2029
2030 (defun truncate-string (string &optional (width 60))
2031   (let ((n (or (position #\newline string)
2032                (min width (length string)))))
2033     (subseq string 0 n)))
2034
2035 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
2036   (let ((*toplevel-compilations* nil))
2037     (cond
2038       ((and (consp sexp) (eq (car sexp) 'progn))
2039        (let ((subs (mapcar (lambda (s)
2040                              (ls-compile-toplevel s t))
2041                            (cdr sexp))))
2042          (join (remove-if #'null-or-empty-p subs))))
2043       (t
2044        (when *compile-print-toplevels*
2045          (let ((form-string (prin1-to-string sexp)))
2046            (write-string "Compiling ")
2047            (write-string (truncate-string form-string))
2048            (write-line "...")))
2049
2050        (let ((code (ls-compile sexp multiple-value-p)))
2051          (code (join-trailing (get-toplevel-compilations)
2052                               (code ";" *newline*))
2053                (when code
2054                  (code code ";" *newline*))))))))
2055
2056
2057 ;;; Once we have the compiler, we define the runtime environment and
2058 ;;; interactive development (eval), which works calling the compiler
2059 ;;; and evaluating the Javascript result globally.
2060
2061 #+ecmalisp
2062 (progn
2063   (defun eval (x)
2064     (js-eval (ls-compile-toplevel x t)))
2065
2066   (defvar * nil)
2067   (defvar ** nil)
2068   (defvar *** nil)
2069   (defvar / nil)
2070   (defvar // nil)
2071   (defvar /// nil)
2072   (defvar + nil)
2073   (defvar ++ nil)
2074   (defvar +++ nil)
2075   (defvar - nil)
2076
2077   (defun eval-interactive (x)
2078     (setf - x)
2079     (let ((results (multiple-value-list (eval x))))
2080       (setf /// //
2081             // /
2082             / results
2083             *** **
2084             ** *
2085             * (car results)))
2086     (setf +++ ++
2087           ++ +
2088           + -)
2089     (values-list /))
2090
2091   (export '(&body &key &optional &rest * *gensym-counter* *package* + - / 1+ 1- <
2092             <= = = > >= and append apply aref arrayp assoc atom block
2093             boundp boundp butlast caar cadddr caddr cadr car car case
2094             catch cdar cdddr cddr cdr cdr char char-code char=
2095             code-char cond cons consp constantly copy-list decf
2096             declaim defconstant define-setf-expander
2097             define-symbol-macro defmacro defparameter defun defvar
2098             digit-char digit-char-p disassemble do do* documentation
2099             dolist dotimes ecase eq eql equal error eval every export
2100             fdefinition find-package find-symbol first flet fourth
2101             fset funcall function functionp gensym get-setf-expansion
2102             get-universal-time go identity if in-package incf integerp
2103             integerp intern keywordp labels lambda last length let
2104             let* list list* list-all-packages listp loop make-array
2105             make-package make-symbol mapcar member minusp mod
2106             multiple-value-bind multiple-value-call
2107             multiple-value-list multiple-value-prog1 nconc nil not
2108             nreconc nth nthcdr null numberp or package-name
2109             package-use-list packagep parse-integer plusp
2110             prin1-to-string print proclaim prog1 prog2 progn psetq
2111             push quote remove remove-if remove-if-not return
2112             return-from revappend reverse rplaca rplacd second set
2113             setf setq some string string-upcase string= stringp subseq
2114             symbol-function symbol-name symbol-package symbol-plist
2115             symbol-value symbolp t tagbody third throw truncate unless
2116             unwind-protect values values-list variable warn when
2117             write-line write-string zerop ** *** // /// ++ +++))
2118
2119   (setq *package* *user-package*)
2120
2121   (js-eval "var lisp")
2122   (%js-vset "lisp" (new))
2123   (%js-vset "lisp.read" #'ls-read-from-string)
2124   (%js-vset "lisp.print" #'prin1-to-string)
2125   (%js-vset "lisp.eval" #'eval)
2126   (%js-vset "lisp.compile" (lambda (s) (ls-compile-toplevel s t)))
2127   (%js-vset "lisp.evalString" (lambda (str) (eval (ls-read-from-string str))))
2128   (%js-vset "lisp.evalInput" (lambda (str) (eval-interactive (ls-read-from-string str))))
2129   (%js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str) t)))
2130
2131   ;; Set the initial global environment to be equal to the host global
2132   ;; environment at this point of the compilation.
2133   (eval-when-compile
2134     (toplevel-compilation
2135      (ls-compile `(setq *environment* ',*environment*))))
2136
2137   (eval-when-compile
2138     (toplevel-compilation
2139      (ls-compile
2140       `(progn
2141          ,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(cdr s))))
2142                    *literal-symbols*)
2143          (setq *literal-symbols* ',*literal-symbols*)
2144          (setq *variable-counter* ,*variable-counter*)
2145          (setq *gensym-counter* ,*gensym-counter*)
2146          (setq *block-counter* ,*block-counter*)))))
2147
2148   (eval-when-compile
2149     (toplevel-compilation
2150      (ls-compile
2151       `(setq *literal-counter* ,*literal-counter*)))))
2152
2153
2154 ;;; Finally, we provide a couple of functions to easily bootstrap
2155 ;;; this. It just calls the compiler with this file as input.
2156
2157 #+common-lisp
2158 (progn
2159   (defun read-whole-file (filename)
2160     (with-open-file (in filename)
2161       (let ((seq (make-array (file-length in) :element-type 'character)))
2162         (read-sequence seq in)
2163         seq)))
2164
2165   (defun ls-compile-file (filename out &key print)
2166     (let ((*compiling-file* t)
2167           (*compile-print-toplevels* print))
2168       (let* ((source (read-whole-file filename))
2169              (in (make-string-stream source)))
2170         (format t "Compiling ~a...~%" filename)
2171         (loop
2172            for x = (ls-read in)
2173            until (eq x *eof*)
2174            for compilation = (ls-compile-toplevel x)
2175            when (plusp (length compilation))
2176            do (write-string compilation out)))))
2177
2178   (defun bootstrap ()
2179     (setq *environment* (make-lexenv))
2180     (setq *literal-symbols* nil)
2181     (setq *variable-counter* 0
2182           *gensym-counter* 0
2183           *literal-counter* 0
2184           *block-counter* 0)
2185     (with-open-file (out "ecmalisp.js" :direction :output :if-exists :supersede)
2186       (write-string (read-whole-file "prelude.js") out)
2187       (ls-compile-file "boot.lisp" out :print t)
2188       (ls-compile-file "ecmalisp.lisp" out :print t))))