test.lisp

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