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