Update test.lisp with the newer code from lispstrack.lisp

[jscl.git] / test.lisp

diff --git a/test.lisp b/test.lisp
index 3676a91..a77545a 100644 (file)
--- a/test.lisp
+++ b/test.lisp
@@ -2,9 +2,9 @@
 
 (eval-when-compile
   (%compile-defmacro 'defmacro
 
 (eval-when-compile
   (%compile-defmacro 'defmacro

-     (lambda (name args &rest body)
+     '(lambda (name args &rest body)

        `(eval-when-compile
        `(eval-when-compile

-          (%compile-defmacro ',name (lambda ,args ,@body))))))
+          (%compile-defmacro ',name '(lambda ,args ,@body))))))

 
 (defmacro defvar (name value)
   `(progn
 
 (defmacro defvar (name value)
   `(progn

@@ -12,21 +12,47 @@
        (%compile-defvar ',name))
      (setq ,name ,value)))
 
        (%compile-defvar ',name))
      (setq ,name ,value)))
 

-(defvar t 't)
-(defvar nil 'nil)
-

 (defmacro defun (name args &rest body)
   `(progn
      (eval-when-compile
        (%compile-defun ',name))
      (fsetq ,name (lambda ,args ,@body))))
 
 (defmacro defun (name args &rest body)
   `(progn
      (eval-when-compile
        (%compile-defun ',name))
      (fsetq ,name (lambda ,args ,@body))))
 

+(defvar *package* (new))
+
+(defvar nil (make-symbol "NIL"))
+(set *package* "NIL" nil)
+
+(defvar t (make-symbol "T"))
+(set *package* "T" t)
+
+(defun internp (name)
+  (in name *package*))
+
+(defun intern (name)
+  (if (internp name)
+      (get *package* name)
+      (set *package* name (make-symbol name))))
+
+(defun find-symbol (name)
+  (get *package* name))
+

 (defmacro when (condition &rest body)
   `(if ,condition (progn ,@body) nil))
 
 (defmacro unless (condition &rest body)
   `(if ,condition nil (progn ,@body)))
 
 (defmacro when (condition &rest body)
   `(if ,condition (progn ,@body) nil))
 
 (defmacro unless (condition &rest body)
   `(if ,condition nil (progn ,@body)))
 

+(defmacro dolist (iter &rest body)
+  (let ((var (first iter))
+        (g!list (make-symbol "LIST")))
+    `(let ((,g!list ,(second iter))
+           (,var nil))
+       (while ,g!list
+         (setq ,var (car ,g!list))
+         ,@body
+         (setq ,g!list (cdr ,g!list))))))
+

 (defun = (x y) (= x y))
 (defun + (x y) (+ x y))
 (defun - (x y) (- x y))
 (defun = (x y) (= x y))
 (defun + (x y) (+ x y))
 (defun - (x y) (- x y))

@@ -43,8 +69,8 @@
 (defun car (x) (car x))
 (defun caar (x) (car (car x)))
 (defun cadr (x) (car (cdr x)))
 (defun car (x) (car x))
 (defun caar (x) (car (car x)))
 (defun cadr (x) (car (cdr x)))

-(defun caddr (x) (car (cdr x)))
-(defun cadddr (x) (car (cdr x)))
+(defun caddr (x) (car (cdr (cdr x))))
+(defun cadddr (x) (car (cdr (cdr (cdr x)))))

 (defun cdr (x) (cdr x))
 (defun cdar (x) (cdr (car x)))
 (defun cddr (x) (cdr (cdr x)))
 (defun cdr (x) (cdr x))
 (defun cdar (x) (cdr (car x)))
 (defun cddr (x) (cdr (cdr x)))

@@ -61,9 +87,6 @@
 (defun atom (x)
   (not (consp x)))
 
 (defun atom (x)
   (not (consp x)))
 

-(defun listp (x)
-  (or (consp x) (null x)))
-

 (defun ensure-list (x)
   (if (listp x)
       x
 (defun ensure-list (x)
   (if (listp x)
       x

@@ -89,13 +112,18 @@
 (defmacro decf (x)
   `(setq ,x (1- ,x)))
 
 (defmacro decf (x)
   `(setq ,x (1- ,x)))
 

-(defun length (list)
+(defun list-length (list)

   (let ((l 0))
     (while (not (null list))
       (incf l)
       (setq list (cdr list)))
     l))
 
   (let ((l 0))
     (while (not (null list))
       (incf l)
       (setq list (cdr list)))
     l))
 

+(defun length (seq)
+  (if (stringp seq)
+      (string-length seq)
+      (list-length seq)))
+

 (defun mapcar (func list)
   (if (null list)
       '()
 (defun mapcar (func list)
   (if (null list)
       '()

@@ -105,17 +133,6 @@
 (defmacro push (x place)
   `(setq ,place (cons ,x ,place)))
 
 (defmacro push (x place)
   `(setq ,place (cons ,x ,place)))
 

-(defvar *package* (new))
-
-(defun intern (name)
-  (let ((s (get *package* name)))
-    (if s
-        s
-        (set *package* name (make-symbol name)))))
-
-(defun find-symbol (name)
-  (get *package* name))
-

 (defmacro cond (&rest clausules)
   (if (null clausules)
       nil
 (defmacro cond (&rest clausules)
   (if (null clausules)
       nil

@@ -208,9 +225,9 @@
     ((null (cdr forms))
      (car forms))
     (t
     ((null (cdr forms))
      (car forms))
     (t

-     `(if ,(car forms)
-          t
-          (or ,@(cdr forms))))))
+     (let ((g (make-symbol "VAR")))
+       `(let ((,g ,(car forms)))
+          (if ,g ,g (or ,@(cdr forms))))))))

 
 
 (defmacro prog1 (form &rest body)
 
 
 (defmacro prog1 (form &rest body)

@@ -222,10 +239,15 @@
 
 (defun char= (x y) (= x y))
 
 
 (defun char= (x y) (= x y))
 

+(defun <= (x y) (or (< x y) (= x y)))
+(defun >= (x y) (not (< x y)))
+
+(defun listp (x)
+  (or (consp x) (null x)))
+

 (defun integerp (x)
   (and (numberp x) (= (floor x) x)))
 
 (defun integerp (x)
   (and (numberp x) (= (floor x) x)))
 

-

 (defun last (x)
   (if (null (cdr x))
       x
 (defun last (x)
   (if (null (cdr x))
       x

@@ -252,29 +274,32 @@
     ((eql x (car list))
      (remove x (cdr list)))
     (t
     ((eql x (car list))
      (remove x (cdr list)))
     (t

-     (cons (car x) (remove x (cdr list))))))
+     (cons (car list) (remove x (cdr list))))))

 
 (defun digit-char-p (x)
 
 (defun digit-char-p (x)

-  (if (and (< #\0 x) (< x #\9))
+  (if (and (<= #\0 x) (<= x #\9))

       (- x #\0)
       nil))
 
 (defun parse-integer (string)
   (let ((value 0)
         (index 0)
       (- x #\0)
       nil))
 
 (defun parse-integer (string)
   (let ((value 0)
         (index 0)

-        (size (string-length string)))
+        (size (length string)))

     (while (< index size)
       (setq value (+ (* value 10) (digit-char-p (char string index))))
     (while (< index size)
       (setq value (+ (* value 10) (digit-char-p (char string index))))

-      (incf index))))
+      (incf index))
+    value))

 
 (defun every (function seq)
   ;; string
   (let ((ret t)
         (index 0)
 
 (defun every (function seq)
   ;; string
   (let ((ret t)
         (index 0)

-        (size (string-length seq)))
+        (size (length seq)))

     (while (and ret (< index size))
       (unless (funcall function (char seq index))
     (while (and ret (< index size))
       (unless (funcall function (char seq index))

-        (setq ret nil)))))
+        (setq ret nil))
+      (incf index))
+    ret))

 
 (defun eql (x y)
   (eq x y))
 
 (defun eql (x y)
   (eq x y))

@@ -291,6 +316,64 @@
 (defun string= (s1 s2)
   (equal s1 s2))
 
 (defun string= (s1 s2)
   (equal s1 s2))
 

+;; ----------------------------------------------------------
+
+;;; Utils
+
+#+common-lisp
+(progn
+  (defmacro while (condition &body body)
+    `(do ()
+         ((not ,condition))
+       ,@body))
+
+  (defun concat-two (s1 s2)
+    (concatenate 'string s1 s2))
+
+  (defun setcar (cons new)
+    (setf (car cons) new))
+  (defun setcdr (cons new)
+    (setf (cdr cons) new)))
+
+(defvar *newline* (string (code-char 10)))
+
+(defun concat (&rest strs)
+  (!reduce (lambda (s1 s2) (concat-two s1 s2))
+           strs
+           ""))
+
+;;; Concatenate a list of strings, with a separator
+(defun join (list separator)
+  (cond
+    ((null list)
+     "")
+    ((null (cdr list))
+     (car list))
+    (t
+     (concat (car list)
+             separator
+             (join (cdr list) separator)))))
+
+(defun join-trailing (list separator)
+  (cond
+    ((null list)
+     "")
+    ((null (car list))
+     (join-trailing (cdr list) separator))
+    (t
+     (concat (car list) separator (join-trailing (cdr list) separator)))))
+
+(defun integer-to-string (x)
+  (if (zerop x)
+      "0"
+      (let ((digits nil))
+        (while (not (= x 0))
+          (push (mod x 10) digits)
+          (setq x (truncate x 10)))
+        (join (mapcar (lambda (d) (string (char "0123456789" d)))
+                      digits)
+              ""))))
+

 ;;;; Reader
 
 ;;; It is a basic Lisp reader. It does not use advanced stuff
 ;;;; Reader
 
 ;;; It is a basic Lisp reader. It does not use advanced stuff

@@ -322,7 +405,6 @@
 (defun terminalp (ch)
   (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
 
 (defun terminalp (ch)
   (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
 

-

 (defun read-until (stream func)
   (let ((string "")
         (ch))
 (defun read-until (stream func)
   (let ((string "")
         (ch))

@@ -404,6 +486,7 @@
                         (read-until stream #'terminalp))))
             (cond
               ((string= cname "space") (char-code #\space))
                         (read-until stream #'terminalp))))
             (cond
               ((string= cname "space") (char-code #\space))

+              ((string= cname "tab") (char-code #\tab))

               ((string= cname "newline") (char-code #\newline))
               (t (char-code (char cname 0))))))
          (#\+
               ((string= cname "newline") (char-code #\newline))
               (t (char-code (char cname 0))))))
          (#\+

@@ -422,12 +505,10 @@
              (parse-integer string)
              (intern (string-upcase string))))))))
 
              (parse-integer string)
              (intern (string-upcase string))))))))
 

-

 (defun ls-read-from-string (string)
   (ls-read (make-string-stream string)))
 
 
 (defun ls-read-from-string (string)
   (ls-read (make-string-stream string)))
 
 

-

 ;;;; Compiler
 
 (defvar *compilation-unit-checks* '())
 ;;;; Compiler
 
 (defvar *compilation-unit-checks* '())

@@ -508,7 +589,6 @@
   (push (make-binding name 'macro lambda t) *fenv*))
 
 
   (push (make-binding name 'macro lambda t) *fenv*))
 
 

-

 (defvar *compilations* nil)
 
 (defun ls-compile-block (sexps env fenv)
 (defvar *compilations* nil)
 
 (defun ls-compile-block (sexps env fenv)

@@ -525,10 +605,9 @@
   `(push (list ',name (lambda (env fenv ,@args) ,@body))
          *compilations*))
 
   `(push (list ',name (lambda (env fenv ,@args) ,@body))
          *compilations*))
 

-

 (define-compilation if (condition true false)
   (concat "("
 (define-compilation if (condition true false)
   (concat "("

-          (ls-compile condition env fenv)
+          (ls-compile condition env fenv) " !== " (ls-compile nil nil nil)

           " ? "
           (ls-compile true env fenv)
           " : "
           " ? "
           (ls-compile true env fenv)
           " : "

@@ -560,7 +639,7 @@
               *newline*
               (if rest-argument
                   (let ((js!rest (lookup-variable-translation rest-argument new-env)))
               *newline*
               (if rest-argument
                   (let ((js!rest (lookup-variable-translation rest-argument new-env)))

-                    (concat "var " js!rest ";" *newline*
+                    (concat "var " js!rest "= " (ls-compile nil env fenv) ";" *newline*

                             "for (var i = arguments.length-1; i>="
                             (integer-to-string (length required-arguments))
                             "; i--)" *newline*
                             "for (var i = arguments.length-1; i>="
                             (integer-to-string (length required-arguments))
                             "; i--)" *newline*

@@ -585,12 +664,26 @@
 
 ;;; Literals
 
 
 ;;; Literals
 

+(defun escape-string (string)
+  (let ((output "")
+        (index 0)
+        (size (length string)))
+    (while (< index size)
+      (let ((ch (char string index)))
+        (when (or (char= ch #\") (char= ch #\\))
+          (setq output (concat output "\\")))
+        (when (or (char= ch #\newline))
+          (setq output (concat output "\\"))
+          (setq ch #\n))
+        (setq output (concat output (string ch))))
+      (incf index))
+    output))
+

 (defun literal->js (sexp)
   (cond
 (defun literal->js (sexp)
   (cond

-    ((null sexp) "false")

     ((integerp sexp) (integer-to-string sexp))
     ((integerp sexp) (integer-to-string sexp))

-    ((stringp sexp) (concat "\"" sexp "\""))
-    ((symbolp sexp) (concat "{name: \"" (symbol-name sexp) "\"}"))
+    ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
+    ((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *env* *fenv*))

     ((consp sexp) (concat "{car: "
                           (literal->js (car sexp))
                           ", cdr: "
     ((consp sexp) (concat "{car: "
                           (literal->js (car sexp))
                           ", cdr: "

@@ -598,11 +691,9 @@
 
 (let ((counter 0))
   (defun literal (form)
 
 (let ((counter 0))
   (defun literal (form)

-    (if (null form)
-        (literal->js form)
-        (let ((var (concat "l" (integer-to-string (incf counter)))))
-          (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
-          var))))
+    (let ((var (concat "l" (integer-to-string (incf counter)))))
+      (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
+      var)))

 
 (define-compilation quote (sexp)
   (literal sexp))
 
 (define-compilation quote (sexp)
   (literal sexp))

@@ -612,7 +703,7 @@
 
 (define-compilation while (pred &rest body)
   (concat "(function(){ while("
 
 (define-compilation while (pred &rest body)
   (concat "(function(){ while("

-          (ls-compile pred env fenv)
+          (ls-compile pred env fenv) " !== " (ls-compile nil nil nil)

           "){"
           (ls-compile-block body env fenv)
           "}})()"))
           "){"
           (ls-compile-block body env fenv)
           "}})()"))

@@ -682,6 +773,9 @@
 
 ;;; Primitives
 
 
 ;;; Primitives
 

+(defun compile-bool (x)
+  (concat "(" x "?" (ls-compile t nil nil) ": " (ls-compile nil nil nil) ")"))
+

 (define-compilation + (x y)
   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 
 (define-compilation + (x y)
   (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
 

@@ -695,10 +789,14 @@
   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 
 (define-compilation < (x y)
   (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
 
 (define-compilation < (x y)

-  (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))"))
+  (compile-bool (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))")))

 
 (define-compilation = (x y)
 
 (define-compilation = (x y)

-  (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
+  (compile-bool (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))")))
+
+(define-compilation numberp (x)
+  (compile-bool (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")")))
+

 
 (define-compilation mod (x y)
   (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
 
 (define-compilation mod (x y)
   (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))

@@ -707,11 +805,17 @@
   (concat "(Math.floor(" (ls-compile x env fenv) "))"))
 
 (define-compilation null (x)
   (concat "(Math.floor(" (ls-compile x env fenv) "))"))
 
 (define-compilation null (x)

-  (concat "(" (ls-compile x env fenv) "== false)"))
+  (compile-bool (concat "(" (ls-compile x env fenv) "===" (ls-compile nil env fenv) ")")))

 
 (define-compilation cons (x y)
   (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
 
 
 (define-compilation cons (x y)
   (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
 

+(define-compilation consp (x)
+  (compile-bool
+   (concat "(function(){ var tmp = "
+           (ls-compile x env fenv)
+           "; return (typeof tmp == 'object' && 'car' in tmp);})()")))
+

 (define-compilation car (x)
   (concat "(" (ls-compile x env fenv) ").car"))
 
 (define-compilation car (x)
   (concat "(" (ls-compile x env fenv) ").car"))
 

@@ -724,6 +828,12 @@
 (define-compilation setcdr (x new)
   (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
 
 (define-compilation setcdr (x new)
   (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
 

+(define-compilation symbolp (x)
+  (compile-bool
+   (concat "(function(){ var tmp = "
+           (ls-compile x env fenv)
+           "; return (typeof tmp == 'object' && 'name' in tmp); })()")))
+

 (define-compilation make-symbol (name)
   (concat "{name: " (ls-compile name env fenv) "}"))
 
 (define-compilation make-symbol (name)
   (concat "{name: " (ls-compile name env fenv) "}"))
 

@@ -731,14 +841,20 @@
   (concat "(" (ls-compile x env fenv) ").name"))
 
 (define-compilation eq (x y)
   (concat "(" (ls-compile x env fenv) ").name"))
 
 (define-compilation eq (x y)

-  (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")"))
+  (compile-bool
+   (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")")))

 
 (define-compilation equal (x y)
 
 (define-compilation equal (x y)

-  (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")"))
+  (compile-bool
+   (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")")))

 
 (define-compilation string (x)
   (concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
 
 
 (define-compilation string (x)
   (concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
 

+(define-compilation stringp (x)
+  (compile-bool
+   (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")")))
+

 (define-compilation string-upcase (x)
   (concat "(" (ls-compile x env fenv) ").toUpperCase()"))
 
 (define-compilation string-upcase (x)
   (concat "(" (ls-compile x env fenv) ").toUpperCase()"))
 

@@ -769,6 +885,30 @@
                 ", ")
           ")"))
 
                 ", ")
           ")"))
 

+(define-compilation apply (func &rest args)
+  (if (null args)
+      (concat "(" (ls-compile func env fenv) ")()")
+      (let ((args (butlast args))
+            (last (car (last args))))
+        (concat "(function(){" *newline*
+                "var f = " (ls-compile func env fenv) ";" *newline*
+                "var args = [" (join (mapcar (lambda (x)
+                                               (ls-compile x env fenv))
+                                             args)
+                                     ", ")
+                "];" *newline*
+                "var tail = (" (ls-compile last env fenv) ");" *newline*
+                "while (tail != " (ls-compile nil env fenv) "){" *newline*
+                "    args.push(tail.car);" *newline*
+                "    tail = tail.cdr;" *newline*
+                "}" *newline*
+                "return f.apply(this, args);" *newline*
+                "})()" *newline*))))
+
+(define-compilation js-eval (string)
+  (concat "eval(" (ls-compile string env fenv)  ")"))
+
+

 (define-compilation error (string)
   (concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
 
 (define-compilation error (string)
   (concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
 

@@ -776,7 +916,11 @@
   "{}")
 
 (define-compilation get (object key)
   "{}")
 
 (define-compilation get (object key)

-  (concat "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"))
+  (concat "(function(){ var tmp = "
+          "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"
+          ";"
+          "return tmp == undefined? " (ls-compile nil nil nil) ": tmp ;"
+          "})()"))

 
 (define-compilation set (object key value)
   (concat "(("
 
 (define-compilation set (object key value)
   (concat "(("

@@ -785,10 +929,15 @@
           (ls-compile key env fenv) "]"
           " = " (ls-compile value env fenv) ")"))
 
           (ls-compile key env fenv) "]"
           " = " (ls-compile value env fenv) ")"))
 

+(define-compilation in (key object)
+  (compile-bool
+   (concat "(" (ls-compile key env fenv) " in " (ls-compile object env fenv) ")")))
+
+

 (defun macrop (x)
   (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
 
 (defun macrop (x)
   (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
 

-(defun ls-macroexpand-1 (form &optional env fenv)
+(defun ls-macroexpand-1 (form env fenv)

   (when (macrop (car form))
     (let ((binding (lookup-function (car form) *env*)))
       (if (eq (binding-type binding) 'macro)
   (when (macrop (car form))
     (let ((binding (lookup-function (car form) *env*)))
       (if (eq (binding-type binding) 'macro)

@@ -811,11 +960,11 @@
     (t
      (error (concat "Invalid function designator " (symbol-name function))))))
 
     (t
      (error (concat "Invalid function designator " (symbol-name function))))))
 

-(defun ls-compile (sexp &optional env fenv)
+(defun ls-compile (sexp env fenv)

   (cond
     ((symbolp sexp) (lookup-variable-translation sexp env))
     ((integerp sexp) (integer-to-string sexp))
   (cond
     ((symbolp sexp) (lookup-variable-translation sexp env))
     ((integerp sexp) (integer-to-string sexp))

-    ((stringp sexp) (concat "\"" sexp "\""))
+    ((stringp sexp) (concat "\"" (escape-string sexp) "\""))

     ((listp sexp)
      (if (assoc (car sexp) *compilations*)
          (let ((comp (second (assoc (car sexp) *compilations*))))
     ((listp sexp)
      (if (assoc (car sexp) *compilations*)
          (let ((comp (second (assoc (car sexp) *compilations*))))

@@ -826,14 +975,73 @@
 
 (defun ls-compile-toplevel (sexp)
   (setq *toplevel-compilations* nil)
 
 (defun ls-compile-toplevel (sexp)
   (setq *toplevel-compilations* nil)

-  (let ((code (ls-compile sexp)))
+  (let ((code (ls-compile sexp nil nil)))

     (prog1
     (prog1

-        (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
+        (concat
+                (join (mapcar (lambda (x) (concat x ";" *newline*))

                               *toplevel-compilations*)
                               *toplevel-compilations*)

-                      "")
+               "")

                 code)
       (setq *toplevel-compilations* nil))))
 
                 code)
       (setq *toplevel-compilations* nil))))
 

+#+common-lisp
+(progn
+  (defun read-whole-file (filename)
+    (with-open-file (in filename)
+      (let ((seq (make-array (file-length in) :element-type 'character)))
+        (read-sequence seq in)
+        seq)))
+
+  (defun ls-compile-file (filename output)
+    (setq *env* nil *fenv* nil)
+    (setq *compilation-unit-checks* nil)
+    (with-open-file (out output :direction :output :if-exists :supersede)
+      (let* ((source (read-whole-file filename))
+             (in (make-string-stream source)))
+        (loop
+           for x = (ls-read in)
+           until (eq x *eof*)
+           for compilation = (ls-compile-toplevel x)
+           when (plusp (length compilation))
+           do (write-line (concat compilation "; ") out))
+        (dolist (check *compilation-unit-checks*)
+          (funcall check))
+        (setq *compilation-unit-checks* nil))))
+
+  (defun bootstrap ()
+    (ls-compile-file "lispstrack.lisp" "lispstrack.js")))
+
+
+;;; ----------------------------------------------------------
+
+(defmacro with-compilation-unit (&rest body)
+  `(prog1 (progn ,@body)
+     (dolist (check *compilation-unit-checks*)
+       (funcall check))
+     (setq *compilation-unit-checks* nil)))

 
 (defun eval (x)
 
 (defun eval (x)

-  (js-eval (ls-compile x nil nil)))
+  (let ((code
+         (with-compilation-unit
+             (ls-compile-toplevel x nil nil))))
+    (js-eval code)))
+
+;; Set the initial global environment to be equal to the host global
+;; environment at this point of the compilation.
+(eval-when-compile
+  (let ((c1 (ls-compile `(setq *fenv* ',*fenv*) nil nil))
+        (c2 (ls-compile `(setq  *env*  ',*env*) nil nil)))
+    (setq *toplevel-compilations*
+          (append *toplevel-compilations* (list c1 c2)))))
+
+(js-eval
+ (concat "var lisp = {};"
+         "lisp.read = " (lookup-function-translation 'ls-read-from-string nil) ";" *newline*
+         "lisp.eval = " (lookup-function-translation 'eval nil) ";" *newline*
+         "lisp.compile = " (lookup-function-translation 'ls-compile-toplevel nil) ";" *newline*
+         "lisp.evalString = function(str){" *newline*
+         "   return lisp.eval(lisp.read(str));" *newline*
+         "}" *newline*
+         "lisp.compileString = function(str){" *newline*
+         "   return lisp.compile(lisp.read(str));" *newline*
+         "}" *newline*))