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
 517 (defvar *compilations* nil)
 518
 519 (defun ls-compile-block (sexps env fenv)
 520   (join-trailing
 521    (remove nil (mapcar (lambda (x)
 522                          (ls-compile x env fenv))
 523                        sexps))
 524    (concat ";" *newline*)))
 525
 526 (defmacro define-compilation (name args &rest body)
 527   ;; Creates a new primitive `name' with parameters args and
 528   ;; @body. The body can access to the local environment through the
 529   ;; variable ENV.
 530   `(push (list ',name (lambda (env fenv ,@args) ,@body))
 531          *compilations*))
 532
 533
 534 (define-compilation if (condition true false)
 535   (concat "("
 536           (ls-compile condition env fenv)
 537           " ? "
 538           (ls-compile true env fenv)
 539           " : "
 540           (ls-compile false env fenv)
 541           ")"))
 542
 543 ;;; Return the required args of a lambda list
 544 (defun lambda-list-required-argument (lambda-list)
 545   (if (or (null lambda-list) (eq (car lambda-list) '&rest))
 546       nil
 547       (cons (car lambda-list) (lambda-list-required-argument (cdr lambda-list)))))
 548
 549 (defun lambda-list-rest-argument (lambda-list)
 550   (second (member '&rest lambda-list)))
 551
 552 (define-compilation lambda (lambda-list &rest body)
 553   (let ((required-arguments (lambda-list-required-argument lambda-list))
 554         (rest-argument (lambda-list-rest-argument lambda-list)))
 555     (let ((new-env (extend-local-env
 556                     (append (and rest-argument (list rest-argument))
 557                             required-arguments)
 558                     env)))
 559       (concat "(function ("
 560               (join (mapcar (lambda (x)
 561                               (lookup-variable-translation x new-env))
 562                             required-arguments)
 563                     ",")
 564               "){"
 565               *newline*
 566               (if rest-argument
 567                   (let ((js!rest (lookup-variable-translation rest-argument new-env)))
 568                     (concat "var " js!rest "= false;" *newline*
 569                             "for (var i = arguments.length-1; i>="
 570                             (integer-to-string (length required-arguments))
 571                             "; i--)" *newline*
 572                             js!rest " = "
 573                             "{car: arguments[i], cdr: " js!rest "};"
 574                             *newline*))
 575                   "")
 576               (concat (ls-compile-block (butlast body) new-env fenv)
 577                       "return " (ls-compile (car (last body)) new-env fenv) ";")
 578               *newline*
 579               "})"))))
 580
 581 (define-compilation fsetq (var val)
 582   (concat (lookup-function-translation var fenv)
 583           " = "
 584           (ls-compile val env fenv)))
 585
 586 (define-compilation setq (var val)
 587   (concat (lookup-variable-translation var env)
 588           " = "
 589            (ls-compile val env fenv)))
 590
 591 ;;; Literals
 592
 593 (defun literal->js (sexp)
 594   (cond
 595     ((null sexp) "false")
 596     ((integerp sexp) (integer-to-string sexp))
 597     ((stringp sexp) (concat "\"" sexp "\""))
 598     ((symbolp sexp) (concat "{name: \"" (symbol-name sexp) "\"}"))
 599     ((consp sexp) (concat "{car: "
 600                           (literal->js (car sexp))
 601                           ", cdr: "
 602                           (literal->js (cdr sexp)) "}"))))
 603
 604 (let ((counter 0))
 605   (defun literal (form)
 606     (if (null form)
 607         (literal->js form)
 608         (let ((var (concat "l" (integer-to-string (incf counter)))))
 609           (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
 610           var))))
 611
 612 (define-compilation quote (sexp)
 613   (literal sexp))
 614
 615 (define-compilation debug (form)
 616   (concat "console.log(" (ls-compile form env fenv) ")"))
 617
 618 (define-compilation while (pred &rest body)
 619   (concat "(function(){ while("
 620           (ls-compile pred env fenv)
 621           "){"
 622           (ls-compile-block body env fenv)
 623           "}})()"))
 624
 625 (define-compilation function (x)
 626   (cond
 627     ((and (listp x) (eq (car x) 'lambda))
 628      (ls-compile x env fenv))
 629     ((symbolp x)
 630      (lookup-function-translation x fenv))))
 631
 632 #+common-lisp
 633 (defmacro eval-when-compile (&body body)
 634   `(eval-when (:compile-toplevel :load-toplevel :execute)
 635      ,@body))
 636
 637 (define-compilation eval-when-compile (&rest body)
 638   (eval (cons 'progn body))
 639   nil)
 640
 641 (defmacro define-transformation (name args form)
 642   `(define-compilation ,name ,args
 643      (ls-compile ,form env fenv)))
 644
 645 (define-transformation progn (&rest body)
 646   `((lambda () ,@body)))
 647
 648 (define-transformation let (bindings &rest body)
 649   (let ((bindings (mapcar #'ensure-list bindings)))
 650     `((lambda ,(mapcar 'car bindings) ,@body)
 651       ,@(mapcar 'cadr bindings))))
 652
 653 ;;; A little backquote implementation without optimizations of any
 654 ;;; kind for lispstrack.
 655 (defun backquote-expand-1 (form)
 656   (cond
 657     ((symbolp form)
 658      (list 'quote form))
 659     ((atom form)
 660      form)
 661     ((eq (car form) 'unquote)
 662      (car form))
 663     ((eq (car form) 'backquote)
 664      (backquote-expand-1 (backquote-expand-1 (cadr form))))
 665     (t
 666      (cons 'append
 667            (mapcar (lambda (s)
 668                      (cond
 669                        ((and (listp s) (eq (car s) 'unquote))
 670                         (list 'list (cadr s)))
 671                        ((and (listp s) (eq (car s) 'unquote-splicing))
 672                         (cadr s))
 673                        (t
 674                         (list 'list (backquote-expand-1 s)))))
 675                    form)))))
 676
 677 (defun backquote-expand (form)
 678   (if (and (listp form) (eq (car form) 'backquote))
 679       (backquote-expand-1 (cadr form))
 680       form))
 681
 682 (defmacro backquote (form)
 683   (backquote-expand-1 form))
 684
 685 (define-transformation backquote (form)
 686   (backquote-expand-1 form))
 687
 688 ;;; Primitives
 689
 690 (define-compilation + (x y)
 691   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 692
 693 (define-compilation - (x y)
 694   (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
 695
 696 (define-compilation * (x y)
 697   (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
 698
 699 (define-compilation / (x y)
 700   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 701
 702 (define-compilation < (x y)
 703   (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))"))
 704
 705 (define-compilation = (x y)
 706   (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
 707
 708 (define-compilation mod (x y)
 709   (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
 710
 711 (define-compilation floor (x)
 712   (concat "(Math.floor(" (ls-compile x env fenv) "))"))
 713
 714 (define-compilation null (x)
 715   (concat "(" (ls-compile x env fenv) "== false)"))
 716
 717 (define-compilation cons (x y)
 718   (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
 719
 720 (define-compilation car (x)
 721   (concat "(" (ls-compile x env fenv) ").car"))
 722
 723 (define-compilation cdr (x)
 724   (concat "(" (ls-compile x env fenv) ").cdr"))
 725
 726 (define-compilation setcar (x new)
 727   (concat "((" (ls-compile x env fenv) ").car = " (ls-compile new env fenv) ")"))
 728
 729 (define-compilation setcdr (x new)
 730   (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
 731
 732 (define-compilation make-symbol (name)
 733   (concat "{name: " (ls-compile name env fenv) "}"))
 734
 735 (define-compilation symbol-name (x)
 736   (concat "(" (ls-compile x env fenv) ").name"))
 737
 738 (define-compilation eq (x y)
 739   (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")"))
 740
 741 (define-compilation equal (x y)
 742   (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")"))
 743
 744 (define-compilation string (x)
 745   (concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
 746
 747 (define-compilation string-upcase (x)
 748   (concat "(" (ls-compile x env fenv) ").toUpperCase()"))
 749
 750 (define-compilation string-length (x)
 751   (concat "(" (ls-compile x env fenv) ").length"))
 752
 753 (define-compilation char (string index)
 754   (concat "("
 755           (ls-compile string env fenv)
 756           ").charCodeAt("
 757           (ls-compile index env fenv)
 758           ")"))
 759
 760 (define-compilation concat-two (string1 string2)
 761   (concat "("
 762           (ls-compile string1 env fenv)
 763           ").concat("
 764           (ls-compile string2 env fenv)
 765           ")"))
 766
 767 (define-compilation funcall (func &rest args)
 768   (concat "("
 769           (ls-compile func env fenv)
 770           ")("
 771           (join (mapcar (lambda (x)
 772                           (ls-compile x env fenv))
 773                         args)
 774                 ", ")
 775           ")"))
 776
 777 (define-compilation error (string)
 778   (concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
 779
 780 (define-compilation new ()
 781   "{}")
 782
 783 (define-compilation get (object key)
 784   (concat "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"))
 785
 786 (define-compilation set (object key value)
 787   (concat "(("
 788           (ls-compile object env fenv)
 789           ")["
 790           (ls-compile key env fenv) "]"
 791           " = " (ls-compile value env fenv) ")"))
 792
 793 (defun macrop (x)
 794   (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
 795
 796 (defun ls-macroexpand-1 (form env fenv)
 797   (when (macrop (car form))
 798     (let ((binding (lookup-function (car form) *env*)))
 799       (if (eq (binding-type binding) 'macro)
 800           (apply (eval (binding-translation binding)) (cdr form))
 801           form))))
 802
 803 (defun compile-funcall (function args env fenv)
 804   (cond
 805     ((symbolp function)
 806      (concat (lookup-function-translation function fenv)
 807              "("
 808              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
 809                    ", ")
 810              ")"))
 811     ((and (listp function) (eq (car function) 'lambda))
 812      (concat "(" (ls-compile function env fenv) ")("
 813              (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
 814                    ", ")
 815              ")"))
 816     (t
 817      (error (concat "Invalid function designator " (symbol-name function))))))
 818
 819 (defun ls-compile (sexp env fenv)
 820   (cond
 821     ((symbolp sexp) (lookup-variable-translation sexp env))
 822     ((integerp sexp) (integer-to-string sexp))
 823     ((stringp sexp) (concat "\"" sexp "\""))
 824     ((listp sexp)
 825      (if (assoc (car sexp) *compilations*)
 826          (let ((comp (second (assoc (car sexp) *compilations*))))
 827            (apply comp env fenv (cdr sexp)))
 828          (if (macrop (car sexp))
 829              (ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
 830              (compile-funcall (car sexp) (cdr sexp) env fenv))))))
 831
 832 (defun ls-compile-toplevel (sexp)
 833   (setq *toplevel-compilations* nil)
 834   (let ((code (ls-compile sexp nil nil)))
 835     (prog1
 836         (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
 837                               *toplevel-compilations*)
 838                       "")
 839                 code)
 840       (setq *toplevel-compilations* nil))))
 841
 842
 843 (defun eval (x)
 844   (js-eval (ls-compile x nil nil)))
 845
 846
 847 (debug (eq (ls-read-from-string "+") '+))