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