lispstrack.lisp

   1 ;;; lispstrack.lisp ---
   2
   3 ;; Copyright (C) 2012 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 lispstrack 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 #+lispstrack
  25 (progn
  26  (eval-when-compile
  27    (%compile-defmacro 'defmacro
  28                       '(lambda (name args &rest body)
  29                         `(eval-when-compile
  30                            (%compile-defmacro ',name '(lambda ,args ,@body))))))
  31
  32  (defmacro %defvar (name value)
  33    `(progn
  34       (eval-when-compile
  35         (%compile-defvar ',name))
  36       (setq ,name ,value)))
  37
  38   (defmacro defvar (name &optional value)
  39     `(%defvar ,name ,value))
  40
  41  (defmacro %defun (name args &rest body)
  42    `(progn
  43       (eval-when-compile
  44         (%compile-defun ',name))
  45       (fsetq ,name (lambda ,args ,@body))))
  46
  47   (defmacro defun (name args &rest body)
  48     `(%defun ,name ,args ,@body))
  49
  50  (defvar *package* (new))
  51
  52  (defvar nil (make-symbol "NIL"))
  53  (set *package* "NIL" nil)
  54
  55  (defvar t (make-symbol "T"))
  56  (set *package* "T" t)
  57
  58  (defun internp (name)
  59    (in name *package*))
  60
  61  (defun intern (name)
  62    (if (internp name)
  63        (get *package* name)
  64        (set *package* name (make-symbol name))))
  65
  66  (defun find-symbol (name)
  67    (get *package* name))
  68
  69  (defmacro when (condition &rest body)
  70    `(if ,condition (progn ,@body) nil))
  71
  72  (defmacro unless (condition &rest body)
  73    `(if ,condition nil (progn ,@body)))
  74
  75  (defmacro dolist (iter &rest body)
  76    (let ((var (first iter))
  77          (g!list (make-symbol "LIST")))
  78      `(let ((,g!list ,(second iter))
  79             (,var nil))
  80         (while ,g!list
  81           (setq ,var (car ,g!list))
  82           ,@body
  83           (setq ,g!list (cdr ,g!list))))))
  84
  85  (defun = (x y) (= x y))
  86  (defun + (x y) (+ x y))
  87  (defun - (x y) (- x y))
  88  (defun * (x y) (* x y))
  89  (defun / (x y) (/ x y))
  90  (defun 1+ (x) (+ x 1))
  91  (defun 1- (x) (- x 1))
  92  (defun zerop (x) (= x 0))
  93  (defun not (x) (if x nil t))
  94
  95  (defun truncate (x y) (floor (/ x y)))
  96
  97  (defun cons (x y ) (cons x y))
  98  (defun consp (x) (consp x))
  99
 100  (defun car (x) (car x))
 101  (defun cdr (x) (cdr x))
 102
 103  (defun caar (x) (car (car x)))
 104  (defun cadr (x) (car (cdr x)))
 105  (defun cdar (x) (cdr (car x)))
 106  (defun cddr (x) (cdr (cdr x)))
 107  (defun caddr (x) (car (cdr (cdr x))))
 108  (defun cdddr (x) (cdr (cdr (cdr x))))
 109  (defun cadddr (x) (car (cdr (cdr (cdr x)))))
 110
 111  (defun first (x) (car x))
 112  (defun second (x) (cadr x))
 113  (defun third (x) (caddr x))
 114  (defun fourth (x) (cadddr x))
 115
 116  (defun list (&rest args)
 117    args)
 118
 119  (defun atom (x)
 120    (not (consp x))))
 121
 122 (defun ensure-list (x)
 123   (if (listp x)
 124       x
 125       (list x)))
 126
 127 (defun !reduce (func list initial)
 128   (if (null list)
 129       initial
 130       (!reduce func
 131                (cdr list)
 132                (funcall func initial (car list)))))
 133
 134 #+lispstrack
 135 (progn
 136   (defmacro defun (name args &rest body)
 137     `(progn
 138        (%defun ,name ,args ,@body)
 139        ',name))
 140
 141   (defmacro defvar (name &optional value)
 142     `(progn
 143        (%defvar ,name ,value)
 144        ',name))
 145
 146   (defun append-two (list1 list2)
 147     (if (null list1)
 148         list2
 149         (cons (car list1)
 150               (append (cdr list1) list2))))
 151
 152   (defun append (&rest lists)
 153     (!reduce #'append-two lists '()))
 154
 155   (defun reverse-aux (list acc)
 156     (if (null list)
 157         acc
 158         (reverse-aux (cdr list) (cons (car list) acc))))
 159
 160   (defun reverse (list)
 161     (reverse-aux list '()))
 162
 163   (defmacro incf (x &optional (delta 1))
 164     `(setq ,x (+ ,x ,delta)))
 165
 166   (defmacro decf (x &optional (delta 1))
 167     `(setq ,x (- ,x ,delta)))
 168
 169   (defun list-length (list)
 170     (let ((l 0))
 171       (while (not (null list))
 172         (incf l)
 173         (setq list (cdr list)))
 174       l))
 175
 176   (defun length (seq)
 177     (if (stringp seq)
 178         (string-length seq)
 179         (list-length seq)))
 180
 181   (defun concat-two (s1 s2)
 182     (concat-two s1 s2))
 183
 184   (defun mapcar (func list)
 185     (if (null list)
 186         '()
 187         (cons (funcall func (car list))
 188               (mapcar func (cdr list)))))
 189
 190   (defmacro push (x place)
 191     `(setq ,place (cons ,x ,place)))
 192
 193   (defmacro cond (&rest clausules)
 194     (if (null clausules)
 195         nil
 196         (if (eq (caar clausules) t)
 197             `(progn ,@(cdar clausules))
 198             `(if ,(caar clausules)
 199                  (progn ,@(cdar clausules))
 200                  (cond ,@(cdr clausules))))))
 201
 202   (defmacro case (form &rest clausules)
 203     (let ((!form (make-symbol "FORM")))
 204       `(let ((,!form ,form))
 205          (cond
 206            ,@(mapcar (lambda (clausule)
 207                        (if (eq (car clausule) t)
 208                            clausule
 209                            `((eql ,!form ,(car clausule))
 210                              ,@(cdr clausule))))
 211                      clausules)))))
 212
 213   (defmacro ecase (form &rest clausules)
 214     `(case ,form
 215        ,@(append
 216           clausules
 217           `((t
 218              (error "ECASE expression failed."))))))
 219
 220   (defun code-char (x) x)
 221   (defun char-code (x) x)
 222   (defun char= (x y) (= x y))
 223
 224   (defmacro and (&rest forms)
 225     (cond
 226       ((null forms)
 227        t)
 228       ((null (cdr forms))
 229        (car forms))
 230       (t
 231        `(if ,(car forms)
 232             (and ,@(cdr forms))
 233             nil))))
 234
 235   (defmacro or (&rest forms)
 236     (cond
 237       ((null forms)
 238        nil)
 239       ((null (cdr forms))
 240        (car forms))
 241       (t
 242        (let ((g (make-symbol "VAR")))
 243          `(let ((,g ,(car forms)))
 244             (if ,g ,g (or ,@(cdr forms))))))))
 245
 246   (defmacro prog1 (form &rest body)
 247     (let ((value (make-symbol "VALUE")))
 248       `(let ((,value ,form))
 249          ,@body
 250          ,value)))
 251
 252   (defun <= (x y) (or (< x y) (= x y)))
 253   (defun >= (x y) (not (< x y)))
 254
 255   (defun plusp (x) (< 0 x))
 256   (defun minusp (x) (< x 0))
 257
 258   (defun listp (x)
 259     (or (consp x) (null x)))
 260
 261   (defun nth (n list)
 262     (cond
 263       ((null list) list)
 264       ((zerop n) (car list))
 265       (t (nth (1- n) (cdr list)))))
 266
 267   (defun integerp (x)
 268     (and (numberp x) (= (floor x) x)))
 269
 270   (defun last (x)
 271     (if (null (cdr x))
 272         x
 273         (last (cdr x))))
 274
 275   (defun butlast (x)
 276     (if (null (cdr x))
 277         nil
 278         (cons (car x) (butlast (cdr x)))))
 279
 280   (defun member (x list)
 281     (cond
 282       ((null list)
 283        nil)
 284       ((eql x (car list))
 285        list)
 286       (t
 287        (member x (cdr list)))))
 288
 289   (defun remove (x list)
 290     (cond
 291       ((null list)
 292        nil)
 293       ((eql x (car list))
 294        (remove x (cdr list)))
 295       (t
 296        (cons (car list) (remove x (cdr list))))))
 297
 298   (defun remove-if (func list)
 299     (cond
 300       ((null list)
 301        nil)
 302       ((funcall func (car list))
 303        (remove-if func (cdr list)))
 304       (t
 305        (cons (car list) (remove-if func (cdr list))))))
 306
 307   (defun remove-if-not (func list)
 308     (cond
 309       ((null list)
 310        nil)
 311       ((funcall func (car list))
 312        (cons (car list) (remove-if-not func (cdr list))))
 313       (t
 314        (remove-if-not func (cdr list)))))
 315
 316   (defun digit-char-p (x)
 317     (if (and (<= #\0 x) (<= x #\9))
 318         (- x #\0)
 319         nil))
 320
 321   (defun parse-integer (string)
 322     (let ((value 0)
 323           (index 0)
 324           (size (length string)))
 325       (while (< index size)
 326         (setq value (+ (* value 10) (digit-char-p (char string index))))
 327         (incf index))
 328       value))
 329
 330   (defun every (function seq)
 331     ;; string
 332     (let ((ret t)
 333           (index 0)
 334           (size (length seq)))
 335       (while (and ret (< index size))
 336         (unless (funcall function (char seq index))
 337           (setq ret nil))
 338         (incf index))
 339       ret))
 340
 341   (defun eql (x y)
 342     (eq x y))
 343
 344   (defun assoc (x alist)
 345     (cond
 346       ((null alist)
 347        nil)
 348       ((eql x (caar alist))
 349        (car alist))
 350       (t
 351        (assoc x (cdr alist)))))
 352
 353   (defun string= (s1 s2)
 354     (equal s1 s2)))
 355
 356
 357 ;;; The compiler offers some primitives and special forms which are
 358 ;;; not found in Common Lisp, for instance, while. So, we grow Common
 359 ;;; Lisp a bit to it can execute the rest of the file.
 360 #+common-lisp
 361 (progn
 362   (defmacro while (condition &body body)
 363     `(do ()
 364          ((not ,condition))
 365        ,@body))
 366
 367   (defmacro eval-when-compile (&body body)
 368     `(eval-when (:compile-toplevel :load-toplevel :execute)
 369        ,@body))
 370
 371   (defun concat-two (s1 s2)
 372     (concatenate 'string s1 s2))
 373
 374   (defun setcar (cons new)
 375     (setf (car cons) new))
 376   (defun setcdr (cons new)
 377     (setf (cdr cons) new)))
 378
 379
 380 ;;; At this point, no matter if Common Lisp or lispstrack is compiling
 381 ;;; from here, this code will compile on both. We define some helper
 382 ;;; functions now for string manipulation and so on. They will be
 383 ;;; useful in the compiler, mostly.
 384
 385 (defvar *newline* (string (code-char 10)))
 386
 387 (defun concat (&rest strs)
 388   (!reduce #'concat-two strs ""))
 389
 390 ;;; Concatenate a list of strings, with a separator
 391 (defun join (list &optional (separator ""))
 392   (cond
 393     ((null list)
 394      "")
 395     ((null (cdr list))
 396      (car list))
 397     (t
 398      (concat (car list)
 399              separator
 400              (join (cdr list) separator)))))
 401
 402 (defun join-trailing (list &optional (separator ""))
 403   (if (null list)
 404       ""
 405       (concat (car list) separator (join-trailing (cdr list) separator))))
 406
 407 (defun integer-to-string (x)
 408   (if (zerop x)
 409       "0"
 410       (let ((digits nil))
 411         (while (not (zerop x))
 412           (push (mod x 10) digits)
 413           (setq x (truncate x 10)))
 414         (join (mapcar (lambda (d) (string (char "0123456789" d)))
 415                       digits)
 416               ""))))
 417
 418 (defun print-to-string (form)
 419   (cond
 420     ((symbolp form) (symbol-name form))
 421     ((integerp form) (integer-to-string form))
 422     ((stringp form) (concat "\"" (escape-string form) "\""))
 423     ((functionp form) (concat "#<FUNCTION>"))
 424     ((listp form)
 425      (concat "("
 426              (join (mapcar #'print-to-string form)
 427                    " ")
 428              ")"))))
 429
 430 ;;;; Reader
 431
 432 ;;; The Lisp reader, parse strings and return Lisp objects. The main
 433 ;;; entry points are `ls-read' and `ls-read-from-string'.
 434
 435 (defun make-string-stream (string)
 436   (cons string 0))
 437
 438 (defun %peek-char (stream)
 439   (and (< (cdr stream) (length (car stream)))
 440        (char (car stream) (cdr stream))))
 441
 442 (defun %read-char (stream)
 443   (and (< (cdr stream) (length (car stream)))
 444        (prog1 (char (car stream) (cdr stream))
 445          (setcdr stream (1+ (cdr stream))))))
 446
 447 (defun whitespacep (ch)
 448   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
 449
 450 (defun skip-whitespaces (stream)
 451   (let (ch)
 452     (setq ch (%peek-char stream))
 453     (while (and ch (whitespacep ch))
 454       (%read-char stream)
 455       (setq ch (%peek-char stream)))))
 456
 457 (defun terminalp (ch)
 458   (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
 459
 460 (defun read-until (stream func)
 461   (let ((string "")
 462         (ch))
 463     (setq ch (%peek-char stream))
 464     (while (not (funcall func ch))
 465       (setq string (concat string (string ch)))
 466       (%read-char stream)
 467       (setq ch (%peek-char stream)))
 468     string))
 469
 470 (defun skip-whitespaces-and-comments (stream)
 471   (let (ch)
 472     (skip-whitespaces stream)
 473     (setq ch (%peek-char stream))
 474     (while (and ch (char= ch #\;))
 475       (read-until stream (lambda (x) (char= x #\newline)))
 476       (skip-whitespaces stream)
 477       (setq ch (%peek-char stream)))))
 478
 479 (defun %read-list (stream)
 480   (skip-whitespaces-and-comments stream)
 481   (let ((ch (%peek-char stream)))
 482     (cond
 483       ((null ch)
 484        (error "Unspected EOF"))
 485       ((char= ch #\))
 486        (%read-char stream)
 487        nil)
 488       ((char= ch #\.)
 489        (%read-char stream)
 490        (prog1 (ls-read stream)
 491          (skip-whitespaces-and-comments stream)
 492          (unless (char= (%read-char stream) #\))
 493            (error "')' was expected."))))
 494       (t
 495        (cons (ls-read stream) (%read-list stream))))))
 496
 497 (defun read-string (stream)
 498   (let ((string "")
 499         (ch nil))
 500     (setq ch (%read-char stream))
 501     (while (not (eql ch #\"))
 502       (when (null ch)
 503         (error "Unexpected EOF"))
 504       (when (eql ch #\\)
 505         (setq ch (%read-char stream)))
 506       (setq string (concat string (string ch)))
 507       (setq ch (%read-char stream)))
 508     string))
 509
 510 (defvar *eof* (make-symbol "EOF"))
 511 (defun ls-read (stream)
 512   (skip-whitespaces-and-comments stream)
 513   (let ((ch (%peek-char stream)))
 514     (cond
 515       ((null ch)
 516        *eof*)
 517       ((char= ch #\()
 518        (%read-char stream)
 519        (%read-list stream))
 520       ((char= ch #\')
 521        (%read-char stream)
 522        (list 'quote (ls-read stream)))
 523       ((char= ch #\`)
 524        (%read-char stream)
 525        (list 'backquote (ls-read stream)))
 526       ((char= ch #\")
 527        (%read-char stream)
 528        (read-string stream))
 529       ((char= ch #\,)
 530        (%read-char stream)
 531        (if (eql (%peek-char stream) #\@)
 532            (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
 533            (list 'unquote (ls-read stream))))
 534       ((char= ch #\#)
 535        (%read-char stream)
 536        (ecase (%read-char stream)
 537          (#\'
 538           (list 'function (ls-read stream)))
 539          (#\\
 540           (let ((cname
 541                  (concat (string (%read-char stream))
 542                          (read-until stream #'terminalp))))
 543             (cond
 544               ((string= cname "space") (char-code #\space))
 545               ((string= cname "tab") (char-code #\tab))
 546               ((string= cname "newline") (char-code #\newline))
 547               (t (char-code (char cname 0))))))
 548          (#\+
 549           (let ((feature (read-until stream #'terminalp)))
 550             (cond
 551               ((string= feature "common-lisp")
 552                (ls-read stream)         ;ignore
 553                (ls-read stream))
 554               ((string= feature "lispstrack")
 555                (ls-read stream))
 556               (t
 557                (error "Unknown reader form.")))))))
 558       (t
 559        (let ((string (read-until stream #'terminalp)))
 560          (if (every #'digit-char-p string)
 561              (parse-integer string)
 562              (intern (string-upcase string))))))))
 563
 564 (defun ls-read-from-string (string)
 565   (ls-read (make-string-stream string)))
 566
 567
 568 ;;;; Compiler
 569
 570 ;;; Translate the Lisp code to Javascript. It will compile the special
 571 ;;; forms. Some primitive functions are compiled as special forms
 572 ;;; too. The respective real functions are defined in the target (see
 573 ;;; the beginning of this file) as well as some primitive functions.
 574
 575 (defvar *compilation-unit-checks* '())
 576
 577 (defvar *env* '())
 578 (defvar *fenv* '())
 579
 580 (defun make-binding (name type js declared)
 581   (list name type js declared))
 582
 583 (defun binding-name (b) (first b))
 584 (defun binding-type (b) (second b))
 585 (defun binding-translation (b) (third b))
 586 (defun binding-declared (b)
 587   (and b (fourth b)))
 588 (defun mark-binding-as-declared (b)
 589   (setcar (cdddr b) t))
 590
 591 (defvar *variable-counter* 0)
 592 (defun gvarname (symbol)
 593   (concat "v" (integer-to-string (incf *variable-counter*))))
 594
 595 (defun lookup-variable (symbol env)
 596   (or (assoc symbol env)
 597       (assoc symbol *env*)
 598       (let ((name (symbol-name symbol))
 599             (binding (make-binding symbol 'variable (gvarname symbol) nil)))
 600         (push binding *env*)
 601         (push (lambda ()
 602                 (unless (binding-declared (assoc symbol *env*))
 603                   (error (concat "Undefined variable `" name "'"))))
 604               *compilation-unit-checks*)
 605         binding)))
 606
 607 (defun lookup-variable-translation (symbol env)
 608   (binding-translation (lookup-variable symbol env)))
 609
 610 (defun extend-local-env (args env)
 611   (append (mapcar (lambda (symbol)
 612                     (make-binding symbol 'variable (gvarname symbol) t))
 613                   args)
 614           env))
 615
 616 (defvar *function-counter* 0)
 617 (defun lookup-function (symbol env)
 618   (or (assoc symbol env)
 619       (assoc symbol *fenv*)
 620       (let ((name (symbol-name symbol))
 621             (binding
 622              (make-binding symbol
 623                            'function
 624                            (concat "f" (integer-to-string (incf *function-counter*)))
 625                            nil)))
 626         (push binding *fenv*)
 627         (push (lambda ()
 628                 (unless (binding-declared (assoc symbol *fenv*))
 629                   (error (concat "Undefined function `" name "'"))))
 630               *compilation-unit-checks*)
 631         binding)))
 632
 633 (defun lookup-function-translation (symbol env)
 634   (binding-translation (lookup-function symbol env)))
 635
 636 (defvar *toplevel-compilations* nil)
 637
 638 (defun %compile-defvar (name)
 639   (let ((b (lookup-variable name *env*)))
 640     (mark-binding-as-declared b)
 641     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 642
 643 (defun %compile-defun (name)
 644   (let ((b (lookup-function name *env*)))
 645     (mark-binding-as-declared b)
 646     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 647
 648 (defun %compile-defmacro (name lambda)
 649   (push (make-binding name 'macro lambda t) *fenv*))
 650
 651 (defvar *compilations* nil)
 652
 653 (defun ls-compile-block (sexps env fenv)
 654   (join-trailing
 655    (remove-if (lambda (x)
 656                 (or (null x)
 657                     (and (stringp x)
 658                          (zerop (length x)))))
 659               (mapcar (lambda (x) (ls-compile x env fenv))  sexps))
 660    (concat ";" *newline*)))
 661
 662 (defmacro define-compilation (name args &rest body)
 663   ;; Creates a new primitive `name' with parameters args and
 664   ;; @body. The body can access to the local environment through the
 665   ;; variable ENV.
 666   `(push (list ',name (lambda (env fenv ,@args) ,@body))
 667          *compilations*))
 668
 669 (define-compilation if (condition true false)
 670   (concat "("
 671           (ls-compile condition env fenv) " !== " (ls-compile nil nil nil)
 672           " ? "
 673           (ls-compile true env fenv)
 674           " : "
 675           (ls-compile false env fenv)
 676           ")"))
 677
 678
 679 (defvar *lambda-list-keywords* '(&optional &rest))
 680
 681 (defun list-until-keyword (list)
 682   (if (or (null list) (member (car list) *lambda-list-keywords*))
 683       nil
 684       (cons (car list) (list-until-keyword (cdr list)))))
 685
 686 (defun lambda-list-required-arguments (lambda-list)
 687   (list-until-keyword lambda-list))
 688
 689 (defun lambda-list-optional-arguments-with-default (lambda-list)
 690   (mapcar #'ensure-list (list-until-keyword (cdr (member '&optional lambda-list)))))
 691
 692 (defun lambda-list-optional-arguments (lambda-list)
 693   (mapcar #'car (lambda-list-optional-arguments-with-default lambda-list)))
 694
 695 (defun lambda-list-rest-argument (lambda-list)
 696   (let ((rest (list-until-keyword (cdr (member '&rest lambda-list)))))
 697     (when (cdr rest)
 698       (error "Bad lambda-list"))
 699     (car rest)))
 700
 701 (define-compilation lambda (lambda-list &rest body)
 702   (let ((required-arguments (lambda-list-required-arguments lambda-list))
 703         (optional-arguments (lambda-list-optional-arguments lambda-list))
 704         (rest-argument (lambda-list-rest-argument lambda-list)))
 705     (let ((n-required-arguments (length required-arguments))
 706           (n-optional-arguments (length optional-arguments))
 707           (new-env (extend-local-env
 708                     (append (ensure-list rest-argument)
 709                             required-arguments
 710                             optional-arguments)
 711                     env)))
 712       (concat "(function ("
 713               (join (mapcar (lambda (x)
 714                               (lookup-variable-translation x new-env))
 715                             (append required-arguments optional-arguments))
 716                     ",")
 717               "){" *newline*
 718               ;; Check number of arguments
 719               (if required-arguments
 720                   (concat "if (arguments.length < " (integer-to-string n-required-arguments)
 721                           ") throw 'too few arguments';" *newline*)
 722                   "")
 723               (if (not rest-argument)
 724                   (concat "if (arguments.length > "
 725                           (integer-to-string (+ n-required-arguments n-optional-arguments))
 726                           ") throw 'too many arguments';" *newline*)
 727                   "")
 728               ;; Optional arguments
 729               (if optional-arguments
 730                   (concat "switch(arguments.length){" *newline*
 731                           (let ((optional-and-defaults
 732                                  (lambda-list-optional-arguments-with-default lambda-list))
 733                                 (cases nil)
 734                                 (idx 0))
 735                             (progn (while (< idx n-optional-arguments)
 736                                      (let ((arg (nth idx optional-and-defaults)))
 737                                        (push (concat "case "
 738                                                      (integer-to-string (+ idx n-required-arguments)) ":" *newline*
 739                                                      (lookup-variable-translation (car arg) new-env)
 740                                                      "="
 741                                                      (ls-compile (cadr arg) new-env fenv)
 742                                                      ";" *newline*)
 743                                              cases)
 744                                        (incf idx)))
 745                                    (push (concat "default: break;" *newline*) cases)
 746                                    (join (reverse cases) "")))
 747                           "}" *newline*)
 748                   "")
 749               ;; &rest argument
 750               (if rest-argument
 751                   (let ((js!rest (lookup-variable-translation rest-argument new-env)))
 752                     (concat "var " js!rest "= " (ls-compile nil env fenv) ";" *newline*
 753                             "for (var i = arguments.length-1; i>="
 754                             (integer-to-string (+ n-required-arguments n-optional-arguments))
 755                             "; i--)" *newline*
 756                             js!rest " = "
 757                             "{car: arguments[i], cdr: " js!rest "};"
 758                             *newline*))
 759                   "")
 760               ;; Body
 761               (concat (ls-compile-block (butlast body) new-env fenv)
 762                       "return " (ls-compile (car (last body)) new-env fenv) ";")
 763               *newline* "})"))))
 764
 765 (define-compilation fsetq (var val)
 766   (concat (lookup-function-translation var fenv)
 767           " = "
 768           (ls-compile val env fenv)))
 769
 770 (define-compilation setq (var val)
 771   (concat (lookup-variable-translation var env)
 772           " = "
 773            (ls-compile val env fenv)))
 774
 775 ;;; Literals
 776 (defun escape-string (string)
 777   (let ((output "")
 778         (index 0)
 779         (size (length string)))
 780     (while (< index size)
 781       (let ((ch (char string index)))
 782         (when (or (char= ch #\") (char= ch #\\))
 783           (setq output (concat output "\\")))
 784         (when (or (char= ch #\newline))
 785           (setq output (concat output "\\"))
 786           (setq ch #\n))
 787         (setq output (concat output (string ch))))
 788       (incf index))
 789     output))
 790
 791 (defun literal->js (sexp)
 792   (cond
 793     ((integerp sexp) (integer-to-string sexp))
 794     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
 795     ((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *env* *fenv*))
 796     ((consp sexp) (concat "{car: "
 797                           (literal->js (car sexp))
 798                           ", cdr: "
 799                           (literal->js (cdr sexp)) "}"))))
 800
 801 (defvar *literal-counter* 0)
 802 (defun literal (form)
 803   (let ((var (concat "l" (integer-to-string (incf *literal-counter*)))))
 804     (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
 805     var))
 806
 807 (define-compilation quote (sexp)
 808   (literal sexp))
 809
 810 (define-compilation debug (form)
 811   (concat "console.log(" (ls-compile form env fenv) ")"))
 812
 813 (define-compilation while (pred &rest body)
 814   (concat "(function(){ while("
 815           (ls-compile pred env fenv) " !== " (ls-compile nil nil nil)
 816           "){"
 817           (ls-compile-block body env fenv)
 818           "}})()"))
 819
 820 (define-compilation function (x)
 821   (cond
 822     ((and (listp x) (eq (car x) 'lambda))
 823      (ls-compile x env fenv))
 824     ((symbolp x)
 825      (lookup-function-translation x fenv))))
 826
 827 (define-compilation eval-when-compile (&rest body)
 828   (eval (cons 'progn body))
 829   "")
 830
 831 (defmacro define-transformation (name args form)
 832   `(define-compilation ,name ,args
 833      (ls-compile ,form env fenv)))
 834
 835 (define-compilation progn (&rest body)
 836   (concat "(function(){" *newline*
 837           (ls-compile-block (butlast body) env fenv)
 838           "return " (ls-compile (car (last body)) env fenv) ";"
 839           "})()" *newline*))
 840
 841 (define-transformation let (bindings &rest body)
 842   (let ((bindings (mapcar #'ensure-list bindings)))
 843     `((lambda ,(mapcar #'car bindings) ,@body)
 844       ,@(mapcar #'cadr bindings))))
 845
 846 ;;; A little backquote implementation without optimizations of any
 847 ;;; kind for lispstrack.
 848 (defun backquote-expand-1 (form)
 849   (cond
 850     ((symbolp form)
 851      (list 'quote form))
 852     ((atom form)
 853      form)
 854     ((eq (car form) 'unquote)
 855      (car form))
 856     ((eq (car form) 'backquote)
 857      (backquote-expand-1 (backquote-expand-1 (cadr form))))
 858     (t
 859      (cons 'append
 860            (mapcar (lambda (s)
 861                      (cond
 862                        ((and (listp s) (eq (car s) 'unquote))
 863                         (list 'list (cadr s)))
 864                        ((and (listp s) (eq (car s) 'unquote-splicing))
 865                         (cadr s))
 866                        (t
 867                         (list 'list (backquote-expand-1 s)))))
 868                    form)))))
 869
 870 (defun backquote-expand (form)
 871   (if (and (listp form) (eq (car form) 'backquote))
 872       (backquote-expand-1 (cadr form))
 873       form))
 874
 875 (defmacro backquote (form)
 876   (backquote-expand-1 form))
 877
 878 (define-transformation backquote (form)
 879   (backquote-expand-1 form))
 880
 881 ;;; Primitives
 882
 883 (defun compile-bool (x)
 884   (concat "(" x "?" (ls-compile t nil nil) ": " (ls-compile nil nil nil) ")"))
 885
 886 (define-compilation + (x y)
 887   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 888
 889 (define-compilation - (x y)
 890   (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
 891
 892 (define-compilation * (x y)
 893   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
 894
 895 (define-compilation / (x y)
 896   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 897
 898 (define-compilation < (x y)
 899   (compile-bool (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))")))
 900
 901 (define-compilation = (x y)
 902   (compile-bool (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))")))
 903
 904 (define-compilation numberp (x)
 905   (compile-bool (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")")))
 906
 907
 908 (define-compilation mod (x y)
 909   (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
 910
 911 (define-compilation floor (x)
 912   (concat "(Math.floor(" (ls-compile x env fenv) "))"))
 913
 914 (define-compilation null (x)
 915   (compile-bool (concat "(" (ls-compile x env fenv) "===" (ls-compile nil env fenv) ")")))
 916
 917 (define-compilation cons (x y)
 918   (concat "({car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "})"))
 919
 920 (define-compilation consp (x)
 921   (compile-bool
 922    (concat "(function(){ var tmp = "
 923            (ls-compile x env fenv)
 924            "; return (typeof tmp == 'object' && 'car' in tmp);})()")))
 925
 926 (define-compilation car (x)
 927   (concat "(function () { var tmp = " (ls-compile x env fenv)
 928           "; return tmp === " (ls-compile nil nil nil) "? "
 929           (ls-compile nil nil nil)
 930           ": tmp.car; })()"))
 931
 932 (define-compilation cdr (x)
 933   (concat "(function () { var tmp = " (ls-compile x env fenv)
 934           "; return tmp === " (ls-compile nil nil nil) "? "
 935           (ls-compile nil nil nil)
 936           ": tmp.cdr; })()"))
 937
 938 (define-compilation setcar (x new)
 939   (concat "((" (ls-compile x env fenv) ").car = " (ls-compile new env fenv) ")"))
 940
 941 (define-compilation setcdr (x new)
 942   (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
 943
 944 (define-compilation symbolp (x)
 945   (compile-bool
 946    (concat "(function(){ var tmp = "
 947            (ls-compile x env fenv)
 948            "; return (typeof tmp == 'object' && 'name' in tmp); })()")))
 949
 950 (define-compilation make-symbol (name)
 951   (concat "({name: " (ls-compile name env fenv) "})"))
 952
 953 (define-compilation symbol-name (x)
 954   (concat "(" (ls-compile x env fenv) ").name"))
 955
 956 (define-compilation eq (x y)
 957   (compile-bool
 958    (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")")))
 959
 960 (define-compilation equal (x y)
 961   (compile-bool
 962    (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")")))
 963
 964 (define-compilation string (x)
 965   (concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
 966
 967 (define-compilation stringp (x)
 968   (compile-bool
 969    (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")")))
 970
 971 (define-compilation string-upcase (x)
 972   (concat "(" (ls-compile x env fenv) ").toUpperCase()"))
 973
 974 (define-compilation string-length (x)
 975   (concat "(" (ls-compile x env fenv) ").length"))
 976
 977 (define-compilation char (string index)
 978   (concat "("
 979           (ls-compile string env fenv)
 980           ").charCodeAt("
 981           (ls-compile index env fenv)
 982           ")"))
 983
 984 (define-compilation concat-two (string1 string2)
 985   (concat "("
 986           (ls-compile string1 env fenv)
 987           ").concat("
 988           (ls-compile string2 env fenv)
 989           ")"))
 990
 991 (define-compilation funcall (func &rest args)
 992   (concat "("
 993           (ls-compile func env fenv)
 994           ")("
 995           (join (mapcar (lambda (x)
 996                           (ls-compile x env fenv))
 997                         args)
 998                 ", ")
 999           ")"))
1000
1001 (define-compilation apply (func &rest args)
1002   (if (null args)
1003       (concat "(" (ls-compile func env fenv) ")()")
1004       (let ((args (butlast args))
1005             (last (car (last args))))
1006         (concat "(function(){" *newline*
1007                 "var f = " (ls-compile func env fenv) ";" *newline*
1008                 "var args = [" (join (mapcar (lambda (x)
1009                                                (ls-compile x env fenv))
1010                                              args)
1011                                      ", ")
1012                 "];" *newline*
1013                 "var tail = (" (ls-compile last env fenv) ");" *newline*
1014                 "while (tail != " (ls-compile nil env fenv) "){" *newline*
1015                 "    args.push(tail.car);" *newline*
1016                 "    tail = tail.cdr;" *newline*
1017                 "}" *newline*
1018                 "return f.apply(this, args);" *newline*
1019                 "})()" *newline*))))
1020
1021 (define-compilation js-eval (string)
1022   (concat "eval.apply(window, [" (ls-compile string env fenv)  "])"))
1023
1024
1025 (define-compilation error (string)
1026   (concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
1027
1028 (define-compilation new ()
1029   "{}")
1030
1031 (define-compilation get (object key)
1032   (concat "(function(){ var tmp = "
1033           "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"
1034           ";"
1035           "return tmp == undefined? " (ls-compile nil nil nil) ": tmp ;"
1036           "})()"))
1037
1038 (define-compilation set (object key value)
1039   (concat "(("
1040           (ls-compile object env fenv)
1041           ")["
1042           (ls-compile key env fenv) "]"
1043           " = " (ls-compile value env fenv) ")"))
1044
1045 (define-compilation in (key object)
1046   (compile-bool
1047    (concat "(" (ls-compile key env fenv) " in " (ls-compile object env fenv) ")")))
1048
1049 (define-compilation functionp (x)
1050   (compile-bool
1051    (concat "(typeof " (ls-compile x env fenv) " == 'function')")))
1052
1053
1054 (defun macrop (x)
1055   (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
1056
1057 (defun ls-macroexpand-1 (form env fenv)
1058   (if (macrop (car form))
1059       (let ((binding (lookup-function (car form) *env*)))
1060         (if (eq (binding-type binding) 'macro)
1061             (apply (eval (binding-translation binding)) (cdr form))
1062             form))
1063       form))
1064
1065 (defun compile-funcall (function args env fenv)
1066   (cond
1067     ((symbolp function)
1068      (concat (lookup-function-translation function fenv)
1069              "("
1070              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
1071                    ", ")
1072              ")"))
1073     ((and (listp function) (eq (car function) 'lambda))
1074      (concat "(" (ls-compile function env fenv) ")("
1075              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
1076                    ", ")
1077              ")"))
1078     (t
1079      (error (concat "Invalid function designator " (symbol-name function))))))
1080
1081 (defun ls-compile (sexp env fenv)
1082   (cond
1083     ((symbolp sexp) (lookup-variable-translation sexp env))
1084     ((integerp sexp) (integer-to-string sexp))
1085     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
1086     ((listp sexp)
1087      (if (assoc (car sexp) *compilations*)
1088          (let ((comp (second (assoc (car sexp) *compilations*))))
1089            (apply comp env fenv (cdr sexp)))
1090          (if (macrop (car sexp))
1091              (ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
1092              (compile-funcall (car sexp) (cdr sexp) env fenv))))))
1093
1094 (defun ls-compile-toplevel (sexp)
1095   (setq *toplevel-compilations* nil)
1096   (let ((code (ls-compile sexp nil nil)))
1097     (prog1
1098         (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
1099                               *toplevel-compilations*)
1100                "")
1101                 code)
1102       (setq *toplevel-compilations* nil))))
1103
1104
1105 ;;; Once we have the compiler, we define the runtime environment and
1106 ;;; interactive development (eval), which works calling the compiler
1107 ;;; and evaluating the Javascript result globally.
1108
1109 #+lispstrack
1110 (progn
1111  (defmacro with-compilation-unit (&rest body)
1112    `(prog1
1113         (progn
1114           (setq *compilation-unit-checks* nil)
1115           (setq *env* (remove-if-not #'binding-declared *env*))
1116           (setq *fenv* (remove-if-not #'binding-declared *fenv*))
1117           ,@body)
1118       (dolist (check *compilation-unit-checks*)
1119         (funcall check))))
1120
1121  (defun eval (x)
1122    (let ((code
1123           (with-compilation-unit
1124               (ls-compile-toplevel x))))
1125      (js-eval code)))
1126
1127  ;; Set the initial global environment to be equal to the host global
1128  ;; environment at this point of the compilation.
1129  (eval-when-compile
1130    (let ((c1 (ls-compile `(setq *fenv* ',*fenv*) nil nil))
1131          (c2 (ls-compile `(setq *env* ',*env*) nil nil))
1132          (c3 (ls-compile `(setq *variable-counter* ',*variable-counter*) nil nil))
1133          (c4 (ls-compile `(setq *function-counter* ',*function-counter*) nil nil))
1134          (c5 (ls-compile `(setq *literal-counter* ',*literal-counter*) nil nil)))
1135      (setq *toplevel-compilations*
1136            (append *toplevel-compilations* (list c1 c2 c3 c4 c5)))))
1137
1138  (js-eval
1139   (concat "var lisp = {};"
1140           "lisp.read = " (lookup-function-translation 'ls-read-from-string nil) ";" *newline*
1141           "lisp.print = " (lookup-function-translation 'print-to-string nil) ";" *newline*
1142           "lisp.eval = " (lookup-function-translation 'eval nil) ";" *newline*
1143           "lisp.compile = " (lookup-function-translation 'ls-compile-toplevel nil) ";" *newline*
1144           "lisp.evalString = function(str){" *newline*
1145           "   return lisp.eval(lisp.read(str));" *newline*
1146           "}" *newline*
1147           "lisp.compileString = function(str){" *newline*
1148           "   return lisp.compile(lisp.read(str));" *newline*
1149           "}" *newline*)))
1150
1151
1152 ;;; Finally, we provide a couple of functions to easily bootstrap
1153 ;;; this. It just calls the compiler with this file as input.
1154
1155 #+common-lisp
1156 (progn
1157   (defun read-whole-file (filename)
1158     (with-open-file (in filename)
1159       (let ((seq (make-array (file-length in) :element-type 'character)))
1160         (read-sequence seq in)
1161         seq)))
1162
1163   (defun ls-compile-file (filename output)
1164     (setq *env* nil *fenv* nil)
1165     (setq *compilation-unit-checks* nil)
1166     (with-open-file (out output :direction :output :if-exists :supersede)
1167       (let* ((source (read-whole-file filename))
1168              (in (make-string-stream source)))
1169         (loop
1170            for x = (ls-read in)
1171            until (eq x *eof*)
1172            for compilation = (ls-compile-toplevel x)
1173            when (plusp (length compilation))
1174            do (write-line (concat compilation "; ") out))
1175         (dolist (check *compilation-unit-checks*)
1176           (funcall check))
1177         (setq *compilation-unit-checks* nil))))
1178
1179   (defun bootstrap ()
1180     (ls-compile-file "lispstrack.lisp" "lispstrack.js")))