lispstrack.lisp

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