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