lispstrack.lisp

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