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