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