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