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