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