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