lispstrack.lisp

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