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