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
 409 ;;;; Reader
 410
 411 ;;; The Lisp reader, parse strings and return Lisp objects. The main
 412 ;;; entry points are `ls-read' and `ls-read-from-string'.
 413
 414 (defun make-string-stream (string)
 415   (cons string 0))
 416
 417 (defun %peek-char (stream)
 418   (and (< (cdr stream) (length (car stream)))
 419        (char (car stream) (cdr stream))))
 420
 421 (defun %read-char (stream)
 422   (and (< (cdr stream) (length (car stream)))
 423        (prog1 (char (car stream) (cdr stream))
 424          (setcdr stream (1+ (cdr stream))))))
 425
 426 (defun whitespacep (ch)
 427   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
 428
 429 (defun skip-whitespaces (stream)
 430   (let (ch)
 431     (setq ch (%peek-char stream))
 432     (while (and ch (whitespacep ch))
 433       (%read-char stream)
 434       (setq ch (%peek-char stream)))))
 435
 436 (defun terminalp (ch)
 437   (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
 438
 439 (defun read-until (stream func)
 440   (let ((string "")
 441         (ch))
 442     (setq ch (%peek-char stream))
 443     (while (not (funcall func ch))
 444       (setq string (concat string (string ch)))
 445       (%read-char stream)
 446       (setq ch (%peek-char stream)))
 447     string))
 448
 449 (defun skip-whitespaces-and-comments (stream)
 450   (let (ch)
 451     (skip-whitespaces stream)
 452     (setq ch (%peek-char stream))
 453     (while (and ch (char= ch #\;))
 454       (read-until stream (lambda (x) (char= x #\newline)))
 455       (skip-whitespaces stream)
 456       (setq ch (%peek-char stream)))))
 457
 458 (defun %read-list (stream)
 459   (skip-whitespaces-and-comments stream)
 460   (let ((ch (%peek-char stream)))
 461     (cond
 462       ((null ch)
 463        (error "Unspected EOF"))
 464       ((char= ch #\))
 465        (%read-char stream)
 466        nil)
 467       ((char= ch #\.)
 468        (%read-char stream)
 469        (prog1 (ls-read stream)
 470          (skip-whitespaces-and-comments stream)
 471          (unless (char= (%read-char stream) #\))
 472            (error "')' was expected."))))
 473       (t
 474        (cons (ls-read stream) (%read-list stream))))))
 475
 476 (defun read-string (stream)
 477   (let ((string "")
 478         (ch nil))
 479     (setq ch (%read-char stream))
 480     (while (not (eql ch #\"))
 481       (when (null ch)
 482         (error "Unexpected EOF"))
 483       (when (eql ch #\\)
 484         (setq ch (%read-char stream)))
 485       (setq string (concat string (string ch)))
 486       (setq ch (%read-char stream)))
 487     string))
 488
 489 (defvar *eof* (make-symbol "EOF"))
 490 (defun ls-read (stream)
 491   (skip-whitespaces-and-comments stream)
 492   (let ((ch (%peek-char stream)))
 493     (cond
 494       ((null ch)
 495        *eof*)
 496       ((char= ch #\()
 497        (%read-char stream)
 498        (%read-list stream))
 499       ((char= ch #\')
 500        (%read-char stream)
 501        (list 'quote (ls-read stream)))
 502       ((char= ch #\`)
 503        (%read-char stream)
 504        (list 'backquote (ls-read stream)))
 505       ((char= ch #\")
 506        (%read-char stream)
 507        (read-string stream))
 508       ((char= ch #\,)
 509        (%read-char stream)
 510        (if (eql (%peek-char stream) #\@)
 511            (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
 512            (list 'unquote (ls-read stream))))
 513       ((char= ch #\#)
 514        (%read-char stream)
 515        (ecase (%read-char stream)
 516          (#\'
 517           (list 'function (ls-read stream)))
 518          (#\\
 519           (let ((cname
 520                  (concat (string (%read-char stream))
 521                          (read-until stream #'terminalp))))
 522             (cond
 523               ((string= cname "space") (char-code #\space))
 524               ((string= cname "tab") (char-code #\tab))
 525               ((string= cname "newline") (char-code #\newline))
 526               (t (char-code (char cname 0))))))
 527          (#\+
 528           (let ((feature (read-until stream #'terminalp)))
 529             (cond
 530               ((string= feature "common-lisp")
 531                (ls-read stream)         ;ignore
 532                (ls-read stream))
 533               ((string= feature "lispstrack")
 534                (ls-read stream))
 535               (t
 536                (error "Unknown reader form.")))))))
 537       (t
 538        (let ((string (read-until stream #'terminalp)))
 539          (if (every #'digit-char-p string)
 540              (parse-integer string)
 541              (intern (string-upcase string))))))))
 542
 543 (defun ls-read-from-string (string)
 544   (ls-read (make-string-stream string)))
 545
 546
 547 ;;;; Compiler
 548
 549 ;;; Translate the Lisp code to Javascript. It will compile the special
 550 ;;; forms. Some primitive functions are compiled as special forms
 551 ;;; too. The respective real functions are defined in the target (see
 552 ;;; the beginning of this file) as well as some primitive functions.
 553
 554 (defvar *compilation-unit-checks* '())
 555
 556 (defvar *env* '())
 557 (defvar *fenv* '())
 558
 559 (defun make-binding (name type js declared)
 560   (list name type js declared))
 561
 562 (defun binding-name (b) (first b))
 563 (defun binding-type (b) (second b))
 564 (defun binding-translation (b) (third b))
 565 (defun binding-declared (b)
 566   (and b (fourth b)))
 567 (defun mark-binding-as-declared (b)
 568   (setcar (cdddr b) t))
 569
 570 (defvar *variable-counter* 0)
 571 (defun gvarname (symbol)
 572   (concat "v" (integer-to-string (incf *variable-counter*))))
 573
 574 (defun lookup-variable (symbol env)
 575   (or (assoc symbol env)
 576       (assoc symbol *env*)
 577       (let ((name (symbol-name symbol))
 578             (binding (make-binding symbol 'variable (gvarname symbol) nil)))
 579         (push binding *env*)
 580         (push (lambda ()
 581                 (unless (binding-declared (assoc symbol *env*))
 582                   (error (concat "Undefined variable `" name "'"))))
 583               *compilation-unit-checks*)
 584         binding)))
 585
 586 (defun lookup-variable-translation (symbol env)
 587   (binding-translation (lookup-variable symbol env)))
 588
 589 (defun extend-local-env (args env)
 590   (append (mapcar (lambda (symbol)
 591                     (make-binding symbol 'variable (gvarname symbol) t))
 592                   args)
 593           env))
 594
 595 (defvar *function-counter* 0)
 596 (defun lookup-function (symbol env)
 597   (or (assoc symbol env)
 598       (assoc symbol *fenv*)
 599       (let ((name (symbol-name symbol))
 600             (binding
 601              (make-binding symbol
 602                            'function
 603                            (concat "f" (integer-to-string (incf *function-counter*)))
 604                            nil)))
 605         (push binding *fenv*)
 606         (push (lambda ()
 607                 (unless (binding-declared (assoc symbol *fenv*))
 608                   (error (concat "Undefined function `" name "'"))))
 609               *compilation-unit-checks*)
 610         binding)))
 611
 612 (defun lookup-function-translation (symbol env)
 613   (binding-translation (lookup-function symbol env)))
 614
 615 (defvar *toplevel-compilations* nil)
 616
 617 (defun %compile-defvar (name)
 618   (let ((b (lookup-variable name *env*)))
 619     (mark-binding-as-declared b)
 620     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 621
 622 (defun %compile-defun (name)
 623   (let ((b (lookup-function name *env*)))
 624     (mark-binding-as-declared b)
 625     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 626
 627 (defun %compile-defmacro (name lambda)
 628   (push (make-binding name 'macro lambda t) *fenv*))
 629
 630 (defvar *compilations* nil)
 631
 632 (defun ls-compile-block (sexps env fenv)
 633   (join-trailing
 634    (remove nil (mapcar (lambda (x)
 635                          (ls-compile x env fenv))
 636                        sexps))
 637                  ";
 638 "))
 639 (defmacro define-compilation (name args &rest body)
 640   ;; Creates a new primitive `name' with parameters args and
 641   ;; @body. The body can access to the local environment through the
 642   ;; variable ENV.
 643   `(push (list ',name (lambda (env fenv ,@args) ,@body))
 644          *compilations*))
 645
 646 (define-compilation if (condition true false)
 647   (concat "("
 648           (ls-compile condition env fenv) " !== " (ls-compile nil nil nil)
 649           " ? "
 650           (ls-compile true env fenv)
 651           " : "
 652           (ls-compile false env fenv)
 653           ")"))
 654
 655 ;;; Return the required args of a lambda list
 656 (defun lambda-list-required-argument (lambda-list)
 657   (if (or (null lambda-list) (eq (car lambda-list) '&rest))
 658       nil
 659       (cons (car lambda-list) (lambda-list-required-argument (cdr lambda-list)))))
 660
 661 (defun lambda-list-rest-argument (lambda-list)
 662   (second (member '&rest lambda-list)))
 663
 664 (define-compilation lambda (lambda-list &rest body)
 665   (let ((required-arguments (lambda-list-required-argument lambda-list))
 666         (rest-argument (lambda-list-rest-argument lambda-list)))
 667     (let ((new-env (extend-local-env
 668                     (append (and rest-argument (list rest-argument))
 669                             required-arguments)
 670                     env)))
 671       (concat "(function ("
 672               (join (mapcar (lambda (x)
 673                               (lookup-variable-translation x new-env))
 674                             required-arguments)
 675                     ",")
 676               "){"
 677               *newline*
 678               (if rest-argument
 679                   (let ((js!rest (lookup-variable-translation rest-argument new-env)))
 680                     (concat "var " js!rest "= " (ls-compile nil env fenv) ";" *newline*
 681                             "for (var i = arguments.length-1; i>="
 682                             (integer-to-string (length required-arguments))
 683                             "; i--)" *newline*
 684                             js!rest " = "
 685                             "{car: arguments[i], cdr: " js!rest "};"
 686                             *newline*))
 687                   "")
 688               (concat (ls-compile-block (butlast body) new-env fenv)
 689                       "return " (ls-compile (car (last body)) new-env fenv) ";")
 690               *newline*
 691               "})"))))
 692
 693 (define-compilation fsetq (var val)
 694   (concat (lookup-function-translation var fenv)
 695           " = "
 696           (ls-compile val env fenv)))
 697
 698 (define-compilation setq (var val)
 699   (concat (lookup-variable-translation var env)
 700           " = "
 701            (ls-compile val env fenv)))
 702
 703 ;;; Literals
 704 (defun escape-string (string)
 705   (let ((output "")
 706         (index 0)
 707         (size (length string)))
 708     (while (< index size)
 709       (let ((ch (char string index)))
 710         (when (or (char= ch #\") (char= ch #\\))
 711           (setq output (concat output "\\")))
 712         (when (or (char= ch #\newline))
 713           (setq output (concat output "\\"))
 714           (setq ch #\n))
 715         (setq output (concat output (string ch))))
 716       (incf index))
 717     output))
 718
 719 (defun literal->js (sexp)
 720   (cond
 721     ((integerp sexp) (integer-to-string sexp))
 722     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
 723     ((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *env* *fenv*))
 724     ((consp sexp) (concat "{car: "
 725                           (literal->js (car sexp))
 726                           ", cdr: "
 727                           (literal->js (cdr sexp)) "}"))))
 728
 729 (defvar *literal-counter* 0)
 730 (defun literal (form)
 731   (let ((var (concat "l" (integer-to-string (incf *literal-counter*)))))
 732     (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
 733     var))
 734
 735 (define-compilation quote (sexp)
 736   (literal sexp))
 737
 738 (define-compilation debug (form)
 739   (concat "console.log(" (ls-compile form env fenv) ")"))
 740
 741 (define-compilation while (pred &rest body)
 742   (concat "(function(){ while("
 743           (ls-compile pred env fenv) " !== " (ls-compile nil nil nil)
 744           "){"
 745           (ls-compile-block body env fenv)
 746           "}})()"))
 747
 748 (define-compilation function (x)
 749   (cond
 750     ((and (listp x) (eq (car x) 'lambda))
 751      (ls-compile x env fenv))
 752     ((symbolp x)
 753      (lookup-function-translation x fenv))))
 754
 755 (define-compilation eval-when-compile (&rest body)
 756   (eval (cons 'progn body))
 757   nil)
 758
 759 (defmacro define-transformation (name args form)
 760   `(define-compilation ,name ,args
 761      (ls-compile ,form env fenv)))
 762
 763 (define-transformation progn (&rest body)
 764   `((lambda () ,@body)))
 765
 766 (define-transformation let (bindings &rest body)
 767   (let ((bindings (mapcar #'ensure-list bindings)))
 768     `((lambda ,(mapcar #'car bindings) ,@body)
 769       ,@(mapcar #'cadr bindings))))
 770
 771 ;;; A little backquote implementation without optimizations of any
 772 ;;; kind for lispstrack.
 773 (defun backquote-expand-1 (form)
 774   (cond
 775     ((symbolp form)
 776      (list 'quote form))
 777     ((atom form)
 778      form)
 779     ((eq (car form) 'unquote)
 780      (car form))
 781     ((eq (car form) 'backquote)
 782      (backquote-expand-1 (backquote-expand-1 (cadr form))))
 783     (t
 784      (cons 'append
 785            (mapcar (lambda (s)
 786                      (cond
 787                        ((and (listp s) (eq (car s) 'unquote))
 788                         (list 'list (cadr s)))
 789                        ((and (listp s) (eq (car s) 'unquote-splicing))
 790                         (cadr s))
 791                        (t
 792                         (list 'list (backquote-expand-1 s)))))
 793                    form)))))
 794
 795 (defun backquote-expand (form)
 796   (if (and (listp form) (eq (car form) 'backquote))
 797       (backquote-expand-1 (cadr form))
 798       form))
 799
 800 (defmacro backquote (form)
 801   (backquote-expand-1 form))
 802
 803 (define-transformation backquote (form)
 804   (backquote-expand-1 form))
 805
 806 ;;; Primitives
 807
 808 (defun compile-bool (x)
 809   (concat "(" x "?" (ls-compile t nil nil) ": " (ls-compile nil nil nil) ")"))
 810
 811 (define-compilation + (x y)
 812   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 813
 814 (define-compilation - (x y)
 815   (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
 816
 817 (define-compilation * (x y)
 818   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
 819
 820 (define-compilation / (x y)
 821   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 822
 823 (define-compilation < (x y)
 824   (compile-bool (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))")))
 825
 826 (define-compilation = (x y)
 827   (compile-bool (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))")))
 828
 829 (define-compilation numberp (x)
 830   (compile-bool (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")")))
 831
 832
 833 (define-compilation mod (x y)
 834   (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
 835
 836 (define-compilation floor (x)
 837   (concat "(Math.floor(" (ls-compile x env fenv) "))"))
 838
 839 (define-compilation null (x)
 840   (compile-bool (concat "(" (ls-compile x env fenv) "===" (ls-compile nil env fenv) ")")))
 841
 842 (define-compilation cons (x y)
 843   (concat "({car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "})"))
 844
 845 (define-compilation consp (x)
 846   (compile-bool
 847    (concat "(function(){ var tmp = "
 848            (ls-compile x env fenv)
 849            "; return (typeof tmp == 'object' && 'car' in tmp);})()")))
 850
 851 (define-compilation car (x)
 852   (concat "(function () { var tmp = " (ls-compile x env fenv)
 853           "; return tmp === " (ls-compile nil nil nil) "? "
 854           (ls-compile nil nil nil)
 855           ": tmp.car; })()"))
 856
 857 (define-compilation cdr (x)
 858   (concat "(function () { var tmp = " (ls-compile x env fenv)
 859           "; return tmp === " (ls-compile nil nil nil) "? "
 860           (ls-compile nil nil nil)
 861           ": tmp.cdr; })()"))
 862
 863 (define-compilation setcar (x new)
 864   (concat "((" (ls-compile x env fenv) ").car = " (ls-compile new env fenv) ")"))
 865
 866 (define-compilation setcdr (x new)
 867   (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
 868
 869 (define-compilation symbolp (x)
 870   (compile-bool
 871    (concat "(function(){ var tmp = "
 872            (ls-compile x env fenv)
 873            "; return (typeof tmp == 'object' && 'name' in tmp); })()")))
 874
 875 (define-compilation make-symbol (name)
 876   (concat "{name: " (ls-compile name env fenv) "}"))
 877
 878 (define-compilation symbol-name (x)
 879   (concat "(" (ls-compile x env fenv) ").name"))
 880
 881 (define-compilation eq (x y)
 882   (compile-bool
 883    (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")")))
 884
 885 (define-compilation equal (x y)
 886   (compile-bool
 887    (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")")))
 888
 889 (define-compilation string (x)
 890   (concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
 891
 892 (define-compilation stringp (x)
 893   (compile-bool
 894    (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")")))
 895
 896 (define-compilation string-upcase (x)
 897   (concat "(" (ls-compile x env fenv) ").toUpperCase()"))
 898
 899 (define-compilation string-length (x)
 900   (concat "(" (ls-compile x env fenv) ").length"))
 901
 902 (define-compilation char (string index)
 903   (concat "("
 904           (ls-compile string env fenv)
 905           ").charCodeAt("
 906           (ls-compile index env fenv)
 907           ")"))
 908
 909 (define-compilation concat-two (string1 string2)
 910   (concat "("
 911           (ls-compile string1 env fenv)
 912           ").concat("
 913           (ls-compile string2 env fenv)
 914           ")"))
 915
 916 (define-compilation funcall (func &rest args)
 917   (concat "("
 918           (ls-compile func env fenv)
 919           ")("
 920           (join (mapcar (lambda (x)
 921                           (ls-compile x env fenv))
 922                         args)
 923                 ", ")
 924           ")"))
 925
 926 (define-compilation apply (func &rest args)
 927   (if (null args)
 928       (concat "(" (ls-compile func env fenv) ")()")
 929       (let ((args (butlast args))
 930             (last (car (last args))))
 931         (concat "(function(){" *newline*
 932                 "var f = " (ls-compile func env fenv) ";" *newline*
 933                 "var args = [" (join (mapcar (lambda (x)
 934                                                (ls-compile x env fenv))
 935                                              args)
 936                                      ", ")
 937                 "];" *newline*
 938                 "var tail = (" (ls-compile last env fenv) ");" *newline*
 939                 "while (tail != " (ls-compile nil env fenv) "){" *newline*
 940                 "    args.push(tail.car);" *newline*
 941                 "    tail = tail.cdr;" *newline*
 942                 "}" *newline*
 943                 "return f.apply(this, args);" *newline*
 944                 "})()" *newline*))))
 945
 946 (define-compilation js-eval (string)
 947   (concat "eval.apply(window, [" (ls-compile string env fenv)  "])"))
 948
 949
 950 (define-compilation error (string)
 951   (concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
 952
 953 (define-compilation new ()
 954   "{}")
 955
 956 (define-compilation get (object key)
 957   (concat "(function(){ var tmp = "
 958           "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"
 959           ";"
 960           "return tmp == undefined? " (ls-compile nil nil nil) ": tmp ;"
 961           "})()"))
 962
 963 (define-compilation set (object key value)
 964   (concat "(("
 965           (ls-compile object env fenv)
 966           ")["
 967           (ls-compile key env fenv) "]"
 968           " = " (ls-compile value env fenv) ")"))
 969
 970 (define-compilation in (key object)
 971   (compile-bool
 972    (concat "(" (ls-compile key env fenv) " in " (ls-compile object env fenv) ")")))
 973
 974 (defun macrop (x)
 975   (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
 976
 977 (defun ls-macroexpand-1 (form env fenv)
 978   (if (macrop (car form))
 979       (let ((binding (lookup-function (car form) *env*)))
 980         (if (eq (binding-type binding) 'macro)
 981             (apply (eval (binding-translation binding)) (cdr form))
 982             form))
 983       form))
 984
 985 (defun compile-funcall (function args env fenv)
 986   (cond
 987     ((symbolp function)
 988      (concat (lookup-function-translation function fenv)
 989              "("
 990              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
 991                    ", ")
 992              ")"))
 993     ((and (listp function) (eq (car function) 'lambda))
 994      (concat "(" (ls-compile function env fenv) ")("
 995              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
 996                    ", ")
 997              ")"))
 998     (t
 999      (error (concat "Invalid function designator " (symbol-name function))))))
1000
1001 (defun ls-compile (sexp env fenv)
1002   (cond
1003     ((symbolp sexp) (lookup-variable-translation sexp env))
1004     ((integerp sexp) (integer-to-string sexp))
1005     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
1006     ((listp sexp)
1007      (if (assoc (car sexp) *compilations*)
1008          (let ((comp (second (assoc (car sexp) *compilations*))))
1009            (apply comp env fenv (cdr sexp)))
1010          (if (macrop (car sexp))
1011              (ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
1012              (compile-funcall (car sexp) (cdr sexp) env fenv))))))
1013
1014 (defun ls-compile-toplevel (sexp)
1015   (setq *toplevel-compilations* nil)
1016   (let ((code (ls-compile sexp nil nil)))
1017     (prog1
1018         (concat  #+common-lisp (concat "/* " (princ-to-string sexp) " */")
1019                 (join (mapcar (lambda (x) (concat x ";" *newline*))
1020                               *toplevel-compilations*)
1021                "")
1022                 code)
1023       (setq *toplevel-compilations* nil))))
1024
1025
1026 ;;; Once we have the compiler, we define the runtime environment and
1027 ;;; interactive development (eval), which works calling the compiler
1028 ;;; and evaluating the Javascript result globally.
1029
1030 #+lispstrack
1031 (progn
1032  (defmacro with-compilation-unit (&rest body)
1033    `(prog1
1034         (progn
1035           (setq *compilation-unit-checks* nil)
1036           (setq *env* (remove-if-not #'binding-declared *env*))
1037           (setq *fenv* (remove-if-not #'binding-declared *fenv*))
1038           ,@body)
1039       (dolist (check *compilation-unit-checks*)
1040         (funcall check))))
1041
1042  (defun eval (x)
1043    (let ((code
1044           (with-compilation-unit
1045               (ls-compile-toplevel x nil nil))))
1046      (js-eval code)))
1047
1048  ;; Set the initial global environment to be equal to the host global
1049  ;; environment at this point of the compilation.
1050  (eval-when-compile
1051    (let ((c1 (ls-compile `(setq *fenv* ',*fenv*) nil nil))
1052          (c2 (ls-compile `(setq *env* ',*env*) nil nil))
1053          (c3 (ls-compile `(setq *variable-counter* ',*variable-counter*) nil nil))
1054          (c4 (ls-compile `(setq *function-counter* ',*function-counter*) nil nil))
1055          (c5 (ls-compile `(setq *literal-counter* ',*literal-counter*) nil nil)))
1056      (setq *toplevel-compilations*
1057            (append *toplevel-compilations* (list c1 c2 c3 c4 c5)))))
1058
1059  (js-eval
1060   (concat "var lisp = {};"
1061           "lisp.read = " (lookup-function-translation 'ls-read-from-string nil) ";" *newline*
1062           "lisp.eval = " (lookup-function-translation 'eval nil) ";" *newline*
1063           "lisp.compile = " (lookup-function-translation 'ls-compile-toplevel nil) ";" *newline*
1064           "lisp.evalString = function(str){" *newline*
1065           "   return lisp.eval(lisp.read(str));" *newline*
1066           "}" *newline*
1067           "lisp.compileString = function(str){" *newline*
1068           "   return lisp.compile(lisp.read(str));" *newline*
1069           "}" *newline*)))
1070
1071
1072 ;;; Finally, we provide a couple of functions to easily bootstrap
1073 ;;; this. It just calls the compiler with this file as input.
1074
1075 #+common-lisp
1076 (progn
1077   (defun read-whole-file (filename)
1078     (with-open-file (in filename)
1079       (let ((seq (make-array (file-length in) :element-type 'character)))
1080         (read-sequence seq in)
1081         seq)))
1082
1083   (defun ls-compile-file (filename output)
1084     (setq *env* nil *fenv* nil)
1085     (setq *compilation-unit-checks* nil)
1086     (with-open-file (out output :direction :output :if-exists :supersede)
1087       (let* ((source (read-whole-file filename))
1088              (in (make-string-stream source)))
1089         (loop
1090            for x = (ls-read in)
1091            until (eq x *eof*)
1092            for compilation = (ls-compile-toplevel x)
1093            when (plusp (length compilation))
1094            do (write-line (concat compilation "; ") out))
1095         (dolist (check *compilation-unit-checks*)
1096           (funcall check))
1097         (setq *compilation-unit-checks* nil))))
1098
1099   (defun bootstrap ()
1100     (ls-compile-file "lispstrack.lisp" "lispstrack.js")))