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