CAR and CDR work for NIL object

[jscl.git] / test.lisp

diff --git a/test.lisp b/test.lisp
index a77545a..7652409 100644 (file)
--- a/test.lisp
+++ b/test.lisp
@@ -66,6 +66,8 @@
 (defun truncate (x y) (floor (/ x y)))
 
 (defun cons (x y ) (cons x y))
 (defun truncate (x y) (floor (/ x y)))
 
 (defun cons (x y ) (cons x y))

+(defun consp (x) (consp x))
+

 (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)))

@@ -276,6 +278,24 @@
     (t
      (cons (car list) (remove x (cdr list))))))
 
     (t
      (cons (car list) (remove x (cdr list))))))
 

+(defun remove-if (func list)
+  (cond
+    ((null list)
+     nil)
+    ((funcall func (car list))
+     (remove-if func (cdr list)))
+    (t
+     (cons (car list) (remove-if func (cdr list))))))
+
+(defun remove-if-not (func list)
+  (cond
+    ((null list)
+     nil)
+    ((funcall func (car list))
+     (cons (car list) (remove-if-not func (cdr list))))
+    (t
+     (remove-if-not func (cdr list)))))
+

 (defun digit-char-p (x)
   (if (and (<= #\0 x) (<= x #\9))
       (- x #\0)
 (defun digit-char-p (x)
   (if (and (<= #\0 x) (<= x #\9))
       (- x #\0)

@@ -527,50 +547,50 @@
 (defun mark-binding-as-declared (b)
   (setcar (cdddr b) t))
 
 (defun mark-binding-as-declared (b)
   (setcar (cdddr b) t))
 

-(let ((counter 0))
-  (defun gvarname (symbol)
-    (concat "v" (integer-to-string (incf counter))))
-
-  (defun lookup-variable (symbol env)
-    (or (assoc symbol env)
-        (assoc symbol *env*)
-        (let ((name (symbol-name symbol))
-              (binding (make-binding symbol 'variable (gvarname symbol) nil)))
-          (push binding *env*)
-          (push (lambda ()
-                  (unless (binding-declared (assoc symbol *env*))
-                    (error (concat "Undefined variable `" name "'"))))
-                *compilation-unit-checks*)
-          binding)))
-
-  (defun lookup-variable-translation (symbol env)
-    (binding-translation (lookup-variable symbol env)))
-
-  (defun extend-local-env (args env)
-    (append (mapcar (lambda (symbol)
-                      (make-binding symbol 'variable (gvarname symbol) t))
-                    args)
-            env)))
-
-(let ((counter 0))
-  (defun lookup-function (symbol env)
-    (or (assoc symbol env)
-        (assoc symbol *fenv*)
-        (let ((name (symbol-name symbol))
-              (binding
-               (make-binding symbol
-                             'function
-                             (concat "f" (integer-to-string (incf counter)))
-                             nil)))
-          (push binding *fenv*)
-          (push (lambda ()
-                  (unless (binding-declared (assoc symbol *fenv*))
-                    (error (concat "Undefined function `" name "'"))))
-                *compilation-unit-checks*)
-          binding)))
-
-  (defun lookup-function-translation (symbol env)
-    (binding-translation (lookup-function symbol env))))
+(defvar *variable-counter* 0)
+(defun gvarname (symbol)
+  (concat "v" (integer-to-string (incf *variable-counter*))))
+
+(defun lookup-variable (symbol env)
+  (or (assoc symbol env)
+      (assoc symbol *env*)
+      (let ((name (symbol-name symbol))
+            (binding (make-binding symbol 'variable (gvarname symbol) nil)))
+        (push binding *env*)
+        (push (lambda ()
+                (unless (binding-declared (assoc symbol *env*))
+                  (error (concat "Undefined variable `" name "'"))))
+              *compilation-unit-checks*)
+        binding)))
+
+(defun lookup-variable-translation (symbol env)
+  (binding-translation (lookup-variable symbol env)))
+
+(defun extend-local-env (args env)
+  (append (mapcar (lambda (symbol)
+                    (make-binding symbol 'variable (gvarname symbol) t))
+                  args)
+          env))
+
+(defvar *function-counter* 0)
+(defun lookup-function (symbol env)
+  (or (assoc symbol env)
+      (assoc symbol *fenv*)
+      (let ((name (symbol-name symbol))
+            (binding
+             (make-binding symbol
+                           'function
+                           (concat "f" (integer-to-string (incf *function-counter*)))
+                           nil)))
+        (push binding *fenv*)
+        (push (lambda ()
+                (unless (binding-declared (assoc symbol *fenv*))
+                  (error (concat "Undefined function `" name "'"))))
+              *compilation-unit-checks*)
+        binding)))
+
+(defun lookup-function-translation (symbol env)
+  (binding-translation (lookup-function symbol env)))

 
 
 (defvar *toplevel-compilations* nil)
 
 
 (defvar *toplevel-compilations* nil)

@@ -689,11 +709,11 @@
                           ", cdr: "
                          (literal->js (cdr sexp)) "}"))))
 
                           ", cdr: "
                          (literal->js (cdr sexp)) "}"))))
 

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

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

@@ -716,7 +736,7 @@
      (lookup-function-translation x fenv))))
 
 #+common-lisp
      (lookup-function-translation x fenv))))
 
 #+common-lisp

-(defmacro eval-when-compile (&body body)
+c(defmacro eval-when-compile (&body body)

   `(eval-when (:compile-toplevel :load-toplevel :execute)
      ,@body))
 
   `(eval-when (:compile-toplevel :load-toplevel :execute)
      ,@body))
 

@@ -817,10 +837,16 @@
            "; return (typeof tmp == 'object' && 'car' in tmp);})()")))
 
 (define-compilation car (x)
            "; return (typeof tmp == 'object' && 'car' in tmp);})()")))
 
 (define-compilation car (x)

-  (concat "(" (ls-compile x env fenv) ").car"))
+  (concat "(function () { var tmp = " (ls-compile x env fenv)
+          "; return tmp === " (ls-compile nil nil nil) "? "
+          (ls-compile nil nil nil)
+          ": tmp.car; })()"))

 
 (define-compilation cdr (x)
 
 (define-compilation cdr (x)

-  (concat "(" (ls-compile x env fenv) ").cdr"))
+  (concat "(function () { var tmp = " (ls-compile x env fenv)
+          "; return tmp === " (ls-compile nil nil nil) "? "
+          (ls-compile nil nil nil)
+          ": tmp.cdr; })()"))

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

@@ -977,7 +1003,7 @@
   (setq *toplevel-compilations* nil)
   (let ((code (ls-compile sexp nil nil)))
     (prog1
   (setq *toplevel-compilations* nil)
   (let ((code (ls-compile sexp nil nil)))
     (prog1

-        (concat
+        (concat  #+common-lisp (concat "/* " (princ-to-string sexp) " */")

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

@@ -1011,14 +1037,17 @@
   (defun bootstrap ()
     (ls-compile-file "lispstrack.lisp" "lispstrack.js")))
 
   (defun bootstrap ()
     (ls-compile-file "lispstrack.lisp" "lispstrack.js")))
 

-

 ;;; ----------------------------------------------------------
 
 (defmacro with-compilation-unit (&rest body)
 ;;; ----------------------------------------------------------
 
 (defmacro with-compilation-unit (&rest body)

-  `(prog1 (progn ,@body)
+  `(prog1
+       (progn
+         (setq *compilation-unit-checks* nil)
+         (setq *env* (remove-if-not #'binding-declared *env*))
+         (setq *fenv* (remove-if-not #'binding-declared *fenv*))
+         ,@body)

      (dolist (check *compilation-unit-checks*)
      (dolist (check *compilation-unit-checks*)

-       (funcall check))
-     (setq *compilation-unit-checks* nil)))
+       (funcall check))))

 
 (defun eval (x)
   (let ((code
 
 (defun eval (x)
   (let ((code

@@ -1026,13 +1055,17 @@
              (ls-compile-toplevel x nil nil))))
     (js-eval code)))
 
              (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))
 ;; 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)))
+        (c2 (ls-compile `(setq *env* ',*env*) nil nil))
+        (c3 (ls-compile `(setq *variable-counter* ',*variable-counter*) nil nil))
+        (c4 (ls-compile `(setq *function-counter* ',*function-counter*) nil nil))
+        (c5 (ls-compile `(setq *literal-counter* ',*literal-counter*) nil nil)))

     (setq *toplevel-compilations*
     (setq *toplevel-compilations*

-          (append *toplevel-compilations* (list c1 c2)))))
+          (append *toplevel-compilations* (list c1 c2 c3 c4 c5)))))

 
 (js-eval
  (concat "var lisp = {};"
 
 (js-eval
  (concat "var lisp = {};"