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