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