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