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