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