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