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 (cdr x))))
  79 (defun cdddr (x) (cdr (cdr (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
 554 (defvar *variable-counter* 0)
 555 (defun gvarname (symbol)
 556   (concat "v" (integer-to-string (incf *variable-counter*))))
 557
 558 (defun lookup-variable (symbol env)
 559   (or (assoc symbol env)
 560       (assoc symbol *env*)
 561       (let ((name (symbol-name symbol))
 562             (binding (make-binding symbol 'variable (gvarname symbol) nil)))
 563         (push binding *env*)
 564         (push (lambda ()
 565                 (unless (binding-declared (assoc symbol *env*))
 566                   (error (concat "Undefined variable `" name "'"))))
 567               *compilation-unit-checks*)
 568         binding)))
 569
 570 (defun lookup-variable-translation (symbol env)
 571   (binding-translation (lookup-variable symbol env)))
 572
 573 (defun extend-local-env (args env)
 574   (append (mapcar (lambda (symbol)
 575                     (make-binding symbol 'variable (gvarname symbol) t))
 576                   args)
 577           env))
 578
 579 (defvar *function-counter* 0)
 580 (defun lookup-function (symbol env)
 581   (or (assoc symbol env)
 582       (assoc symbol *fenv*)
 583       (let ((name (symbol-name symbol))
 584             (binding
 585              (make-binding symbol
 586                            'function
 587                            (concat "f" (integer-to-string (incf *function-counter*)))
 588                            nil)))
 589         (push binding *fenv*)
 590         (push (lambda ()
 591                 (unless (binding-declared (assoc symbol *fenv*))
 592                   (error (concat "Undefined function `" name "'"))))
 593               *compilation-unit-checks*)
 594         binding)))
 595
 596 (defun lookup-function-translation (symbol env)
 597   (binding-translation (lookup-function symbol env)))
 598
 599
 600 (defvar *toplevel-compilations* nil)
 601
 602 (defun %compile-defvar (name)
 603   (let ((b (lookup-variable name *env*)))
 604     (mark-binding-as-declared b)
 605     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 606
 607 (defun %compile-defun (name)
 608   (let ((b (lookup-function name *env*)))
 609     (mark-binding-as-declared b)
 610     (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
 611
 612 (defun %compile-defmacro (name lambda)
 613   (push (make-binding name 'macro lambda t) *fenv*))
 614
 615
 616 (defvar *compilations* nil)
 617
 618 (defun ls-compile-block (sexps env fenv)
 619   (join-trailing
 620    (remove nil (mapcar (lambda (x)
 621                          (ls-compile x env fenv))
 622                        sexps))
 623                  ";
 624 "))
 625 (defmacro define-compilation (name args &rest body)
 626   ;; Creates a new primitive `name' with parameters args and
 627   ;; @body. The body can access to the local environment through the
 628   ;; variable ENV.
 629   `(push (list ',name (lambda (env fenv ,@args) ,@body))
 630          *compilations*))
 631
 632 (define-compilation if (condition true false)
 633   (concat "("
 634           (ls-compile condition env fenv) " !== " (ls-compile nil nil nil)
 635           " ? "
 636           (ls-compile true env fenv)
 637           " : "
 638           (ls-compile false env fenv)
 639           ")"))
 640
 641 ;;; Return the required args of a lambda list
 642 (defun lambda-list-required-argument (lambda-list)
 643   (if (or (null lambda-list) (eq (car lambda-list) '&rest))
 644       nil
 645       (cons (car lambda-list) (lambda-list-required-argument (cdr lambda-list)))))
 646
 647 (defun lambda-list-rest-argument (lambda-list)
 648   (second (member '&rest lambda-list)))
 649
 650 (define-compilation lambda (lambda-list &rest body)
 651   (let ((required-arguments (lambda-list-required-argument lambda-list))
 652         (rest-argument (lambda-list-rest-argument lambda-list)))
 653     (let ((new-env (extend-local-env
 654                     (append (and rest-argument (list rest-argument))
 655                             required-arguments)
 656                     env)))
 657       (concat "(function ("
 658               (join (mapcar (lambda (x)
 659                               (lookup-variable-translation x new-env))
 660                             required-arguments)
 661                     ",")
 662               "){"
 663               *newline*
 664               (if rest-argument
 665                   (let ((js!rest (lookup-variable-translation rest-argument new-env)))
 666                     (concat "var " js!rest "= " (ls-compile nil env fenv) ";" *newline*
 667                             "for (var i = arguments.length-1; i>="
 668                             (integer-to-string (length required-arguments))
 669                             "; i--)" *newline*
 670                             js!rest " = "
 671                             "{car: arguments[i], cdr: " js!rest "};"
 672                             *newline*))
 673                   "")
 674               (concat (ls-compile-block (butlast body) new-env fenv)
 675                       "return " (ls-compile (car (last body)) new-env fenv) ";")
 676               *newline*
 677               "})"))))
 678
 679 (define-compilation fsetq (var val)
 680   (concat (lookup-function-translation var fenv)
 681           " = "
 682           (ls-compile val env fenv)))
 683
 684 (define-compilation setq (var val)
 685   (concat (lookup-variable-translation var env)
 686           " = "
 687            (ls-compile val env fenv)))
 688
 689 ;;; Literals
 690
 691 (defun escape-string (string)
 692   (let ((output "")
 693         (index 0)
 694         (size (length string)))
 695     (while (< index size)
 696       (let ((ch (char string index)))
 697         (when (or (char= ch #\") (char= ch #\\))
 698           (setq output (concat output "\\")))
 699         (when (or (char= ch #\newline))
 700           (setq output (concat output "\\"))
 701           (setq ch #\n))
 702         (setq output (concat output (string ch))))
 703       (incf index))
 704     output))
 705
 706 (defun literal->js (sexp)
 707   (cond
 708     ((integerp sexp) (integer-to-string sexp))
 709     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
 710     ((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *env* *fenv*))
 711     ((consp sexp) (concat "{car: "
 712                           (literal->js (car sexp))
 713                           ", cdr: "
 714                           (literal->js (cdr sexp)) "}"))))
 715
 716 (defvar *literal-counter* 0)
 717 (defun literal (form)
 718   (let ((var (concat "l" (integer-to-string (incf *literal-counter*)))))
 719     (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
 720     var))
 721
 722 (define-compilation quote (sexp)
 723   (literal sexp))
 724
 725 (define-compilation debug (form)
 726   (concat "console.log(" (ls-compile form env fenv) ")"))
 727
 728 (define-compilation while (pred &rest body)
 729   (concat "(function(){ while("
 730           (ls-compile pred env fenv) " !== " (ls-compile nil nil nil)
 731           "){"
 732           (ls-compile-block body env fenv)
 733           "}})()"))
 734
 735 (define-compilation function (x)
 736   (cond
 737     ((and (listp x) (eq (car x) 'lambda))
 738      (ls-compile x env fenv))
 739     ((symbolp x)
 740      (lookup-function-translation x fenv))))
 741
 742 #+common-lisp
 743 (defmacro eval-when-compile (&body body)
 744   `(eval-when (:compile-toplevel :load-toplevel :execute)
 745      ,@body))
 746
 747 (define-compilation eval-when-compile (&rest body)
 748   (eval (cons 'progn body))
 749   nil)
 750
 751 (defmacro define-transformation (name args form)
 752   `(define-compilation ,name ,args
 753      (ls-compile ,form env fenv)))
 754
 755 (define-transformation progn (&rest body)
 756   `((lambda () ,@body)))
 757
 758 (define-transformation let (bindings &rest body)
 759   (let ((bindings (mapcar #'ensure-list bindings)))
 760     `((lambda ,(mapcar #'car bindings) ,@body)
 761       ,@(mapcar #'cadr bindings))))
 762
 763 ;;; A little backquote implementation without optimizations of any
 764 ;;; kind for lispstrack.
 765 (defun backquote-expand-1 (form)
 766   (cond
 767     ((symbolp form)
 768      (list 'quote form))
 769     ((atom form)
 770      form)
 771     ((eq (car form) 'unquote)
 772      (car form))
 773     ((eq (car form) 'backquote)
 774      (backquote-expand-1 (backquote-expand-1 (cadr form))))
 775     (t
 776      (cons 'append
 777            (mapcar (lambda (s)
 778                      (cond
 779                        ((and (listp s) (eq (car s) 'unquote))
 780                         (list 'list (cadr s)))
 781                        ((and (listp s) (eq (car s) 'unquote-splicing))
 782                         (cadr s))
 783                        (t
 784                         (list 'list (backquote-expand-1 s)))))
 785                    form)))))
 786
 787 (defun backquote-expand (form)
 788   (if (and (listp form) (eq (car form) 'backquote))
 789       (backquote-expand-1 (cadr form))
 790       form))
 791
 792 (defmacro backquote (form)
 793   (backquote-expand-1 form))
 794
 795 (define-transformation backquote (form)
 796   (backquote-expand-1 form))
 797
 798 ;;; Primitives
 799
 800 (defun compile-bool (x)
 801   (concat "(" x "?" (ls-compile t nil nil) ": " (ls-compile nil nil nil) ")"))
 802
 803 (define-compilation + (x y)
 804   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 805
 806 (define-compilation - (x y)
 807   (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   (compile-bool (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 numberp (x)
 822   (compile-bool (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")")))
 823
 824
 825 (define-compilation mod (x y)
 826   (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
 827
 828 (define-compilation floor (x)
 829   (concat "(Math.floor(" (ls-compile x env fenv) "))"))
 830
 831 (define-compilation null (x)
 832   (compile-bool (concat "(" (ls-compile x env fenv) "===" (ls-compile nil env fenv) ")")))
 833
 834 (define-compilation cons (x y)
 835   (concat "({car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "})"))
 836
 837 (define-compilation consp (x)
 838   (compile-bool
 839    (concat "(function(){ var tmp = "
 840            (ls-compile x env fenv)
 841            "; return (typeof tmp == 'object' && 'car' in tmp);})()")))
 842
 843 (define-compilation car (x)
 844   (concat "(function () { var tmp = " (ls-compile x env fenv)
 845           "; return tmp === " (ls-compile nil nil nil) "? "
 846           (ls-compile nil nil nil)
 847           ": tmp.car; })()"))
 848
 849 (define-compilation cdr (x)
 850   (concat "(function () { var tmp = " (ls-compile x env fenv)
 851           "; return tmp === " (ls-compile nil nil nil) "? "
 852           (ls-compile nil nil nil)
 853           ": tmp.cdr; })()"))
 854
 855 (define-compilation setcar (x new)
 856   (concat "((" (ls-compile x env fenv) ").car = " (ls-compile new env fenv) ")"))
 857
 858 (define-compilation setcdr (x new)
 859   (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
 860
 861 (define-compilation symbolp (x)
 862   (compile-bool
 863    (concat "(function(){ var tmp = "
 864            (ls-compile x env fenv)
 865            "; return (typeof tmp == 'object' && 'name' in tmp); })()")))
 866
 867 (define-compilation make-symbol (name)
 868   (concat "{name: " (ls-compile name env fenv) "}"))
 869
 870 (define-compilation symbol-name (x)
 871   (concat "(" (ls-compile x env fenv) ").name"))
 872
 873 (define-compilation eq (x y)
 874   (compile-bool
 875    (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")")))
 876
 877 (define-compilation equal (x y)
 878   (compile-bool
 879    (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")")))
 880
 881 (define-compilation string (x)
 882   (concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
 883
 884 (define-compilation stringp (x)
 885   (compile-bool
 886    (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")")))
 887
 888 (define-compilation string-upcase (x)
 889   (concat "(" (ls-compile x env fenv) ").toUpperCase()"))
 890
 891 (define-compilation string-length (x)
 892   (concat "(" (ls-compile x env fenv) ").length"))
 893
 894 (define-compilation char (string index)
 895   (concat "("
 896           (ls-compile string env fenv)
 897           ").charCodeAt("
 898           (ls-compile index env fenv)
 899           ")"))
 900
 901 (define-compilation concat-two (string1 string2)
 902   (concat "("
 903           (ls-compile string1 env fenv)
 904           ").concat("
 905           (ls-compile string2 env fenv)
 906           ")"))
 907
 908 (define-compilation funcall (func &rest args)
 909   (concat "("
 910           (ls-compile func env fenv)
 911           ")("
 912           (join (mapcar (lambda (x)
 913                           (ls-compile x env fenv))
 914                         args)
 915                 ", ")
 916           ")"))
 917
 918 (define-compilation apply (func &rest args)
 919   (if (null args)
 920       (concat "(" (ls-compile func env fenv) ")()")
 921       (let ((args (butlast args))
 922             (last (car (last args))))
 923         (concat "(function(){" *newline*
 924                 "var f = " (ls-compile func env fenv) ";" *newline*
 925                 "var args = [" (join (mapcar (lambda (x)
 926                                                (ls-compile x env fenv))
 927                                              args)
 928                                      ", ")
 929                 "];" *newline*
 930                 "var tail = (" (ls-compile last env fenv) ");" *newline*
 931                 "while (tail != " (ls-compile nil env fenv) "){" *newline*
 932                 "    args.push(tail.car);" *newline*
 933                 "    tail = tail.cdr;" *newline*
 934                 "}" *newline*
 935                 "return f.apply(this, args);" *newline*
 936                 "})()" *newline*))))
 937
 938 (define-compilation js-eval (string)
 939   (concat "eval(" (ls-compile string env fenv)  ")"))
 940
 941
 942 (define-compilation error (string)
 943   (concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
 944
 945 (define-compilation new ()
 946   "{}")
 947
 948 (define-compilation get (object key)
 949   (concat "(function(){ var tmp = "
 950           "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"
 951           ";"
 952           "return tmp == undefined? " (ls-compile nil nil nil) ": tmp ;"
 953           "})()"))
 954
 955 (define-compilation set (object key value)
 956   (concat "(("
 957           (ls-compile object env fenv)
 958           ")["
 959           (ls-compile key env fenv) "]"
 960           " = " (ls-compile value env fenv) ")"))
 961
 962 (define-compilation in (key object)
 963   (compile-bool
 964    (concat "(" (ls-compile key env fenv) " in " (ls-compile object env fenv) ")")))
 965
 966
 967 (defun macrop (x)
 968   (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
 969
 970 (defun ls-macroexpand-1 (form env fenv)
 971   (if (macrop (car form))
 972       (let ((binding (lookup-function (car form) *env*)))
 973         (if (eq (binding-type binding) 'macro)
 974             (apply (eval (binding-translation binding)) (cdr form))
 975             form))
 976       form))
 977
 978 (defun compile-funcall (function args env fenv)
 979   (cond
 980     ((symbolp function)
 981      (concat (lookup-function-translation function fenv)
 982              "("
 983              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
 984                    ", ")
 985              ")"))
 986     ((and (listp function) (eq (car function) 'lambda))
 987      (concat "(" (ls-compile function env fenv) ")("
 988              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
 989                    ", ")
 990              ")"))
 991     (t
 992      (error (concat "Invalid function designator " (symbol-name function))))))
 993
 994 (defun ls-compile (sexp env fenv)
 995   (cond
 996     ((symbolp sexp) (lookup-variable-translation sexp env))
 997     ((integerp sexp) (integer-to-string sexp))
 998     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
 999     ((listp sexp)
1000      (if (assoc (car sexp) *compilations*)
1001          (let ((comp (second (assoc (car sexp) *compilations*))))
1002            (apply comp env fenv (cdr sexp)))
1003          (if (macrop (car sexp))
1004              (ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
1005              (compile-funcall (car sexp) (cdr sexp) env fenv))))))
1006
1007 (defun ls-compile-toplevel (sexp)
1008   (setq *toplevel-compilations* nil)
1009   (let ((code (ls-compile sexp nil nil)))
1010     (prog1
1011         (concat  #+common-lisp (concat "/* " (princ-to-string sexp) " */")
1012                 (join (mapcar (lambda (x) (concat x ";" *newline*))
1013                               *toplevel-compilations*)
1014                "")
1015                 code)
1016       (setq *toplevel-compilations* nil))))
1017
1018 #+common-lisp
1019 (progn
1020   (defun read-whole-file (filename)
1021     (with-open-file (in filename)
1022       (let ((seq (make-array (file-length in) :element-type 'character)))
1023         (read-sequence seq in)
1024         seq)))
1025
1026   (defun ls-compile-file (filename output)
1027     (setq *env* nil *fenv* nil)
1028     (setq *compilation-unit-checks* nil)
1029     (with-open-file (out output :direction :output :if-exists :supersede)
1030       (let* ((source (read-whole-file filename))
1031              (in (make-string-stream source)))
1032         (loop
1033            for x = (ls-read in)
1034            until (eq x *eof*)
1035            for compilation = (ls-compile-toplevel x)
1036            when (plusp (length compilation))
1037            do (write-line (concat compilation "; ") out))
1038         (dolist (check *compilation-unit-checks*)
1039           (funcall check))
1040         (setq *compilation-unit-checks* nil))))
1041
1042   (defun bootstrap ()
1043     (ls-compile-file "lispstrack.lisp" "lispstrack.js")))
1044
1045 ;;; ----------------------------------------------------------
1046
1047 (defmacro with-compilation-unit (&rest body)
1048   `(prog1
1049        (progn
1050          (setq *compilation-unit-checks* nil)
1051          (setq *env* (remove-if-not #'binding-declared *env*))
1052          (setq *fenv* (remove-if-not #'binding-declared *fenv*))
1053          ,@body)
1054      (dolist (check *compilation-unit-checks*)
1055        (funcall check))))
1056
1057 (defun eval (x)
1058   (let ((code
1059          (with-compilation-unit
1060              (ls-compile-toplevel x nil nil))))
1061     (js-eval code)))
1062
1063
1064 ;; Set the initial global environment to be equal to the host global
1065 ;; environment at this point of the compilation.
1066 (eval-when-compile
1067   (let ((c1 (ls-compile `(setq *fenv* ',*fenv*) nil nil))
1068         (c2 (ls-compile `(setq *env* ',*env*) nil nil))
1069         (c3 (ls-compile `(setq *variable-counter* ',*variable-counter*) nil nil))
1070         (c4 (ls-compile `(setq *function-counter* ',*function-counter*) nil nil))
1071         (c5 (ls-compile `(setq *literal-counter* ',*literal-counter*) nil nil)))
1072     (setq *toplevel-compilations*
1073           (append *toplevel-compilations* (list c1 c2 c3 c4 c5)))))
1074
1075 (js-eval
1076  (concat "var lisp = {};"
1077          "lisp.read = " (lookup-function-translation 'ls-read-from-string nil) ";" *newline*
1078          "lisp.eval = " (lookup-function-translation 'eval nil) ";" *newline*
1079          "lisp.compile = " (lookup-function-translation 'ls-compile-toplevel nil) ";" *newline*
1080          "lisp.evalString = function(str){" *newline*
1081          "   return lisp.eval(lisp.read(str));" *newline*
1082          "}" *newline*
1083          "lisp.compileString = function(str){" *newline*
1084          "   return lisp.compile(lisp.read(str));" *newline*
1085          "}" *newline*))