test.lisp

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