X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=lispstrack.lisp;h=98f7bc0f5f217b6793a2ded92fb6fe08d7170fe2;hb=a6c50c8a33d0e918ca2b495328592832c88205cc;hp=326030b183da55f070f0a1616a801bda82fe71f2;hpb=8e954d1de03186efb2459f3f01f4952d9e5551f8;p=jscl.git

diff --git a/lispstrack.lisp b/lispstrack.lisp
index 326030b..98f7bc0 100644
--- a/lispstrack.lisp
+++ b/lispstrack.lisp
@@ -178,6 +178,9 @@
         (string-length seq)
         (list-length seq)))
 
+  (defun concat-two (s1 s2)
+    (concat-two s1 s2))
+
   (defun mapcar (func list)
     (if (null list)
         '()
@@ -249,6 +252,9 @@
   (defun <= (x y) (or (< x y) (= x y)))
   (defun >= (x y) (not (< x y)))
 
+  (defun plusp (x) (< 0 x))
+  (defun minusp (x) (< x 0))
+
   (defun listp (x)
     (or (consp x) (null x)))
 
@@ -373,9 +379,7 @@
 (defvar *newline* (string (code-char 10)))
 
 (defun concat (&rest strs)
-  (!reduce (lambda (s1 s2) (concat-two s1 s2))
-           strs
-           ""))
+  (!reduce #'concat-two strs ""))
 
 ;;; Concatenate a list of strings, with a separator
 (defun join (list separator)
@@ -405,6 +409,17 @@
                       digits)
               ""))))
 
+(defun print-to-string (form)
+  (cond
+    ((symbolp form) (symbol-name form))
+    ((integerp form) (integer-to-string form))
+    ((stringp form) (concat "\"" (escape-string form) "\""))
+    ((functionp form) (concat "#<FUNCTION>"))
+    ((listp form)
+     (concat "("
+             (join (mapcar #'print-to-string form)
+                   " ")
+             ")"))))
 
 ;;;; Reader
 
@@ -631,11 +646,13 @@
 
 (defun ls-compile-block (sexps env fenv)
   (join-trailing
-   (remove nil (mapcar (lambda (x)
-                         (ls-compile x env fenv))
-                       sexps))
-                 ";
-"))
+   (remove (lambda (x)
+             (or (null x)
+                 (and (stringp x)
+                      (zerop (length x)))))
+           (mapcar (lambda (x) (ls-compile x env fenv))  sexps))
+   (concat ";" *newline*)))
+
 (defmacro define-compilation (name args &rest body)
   ;; Creates a new primitive `name' with parameters args and
   ;; @body. The body can access to the local environment through the
@@ -971,6 +988,11 @@
   (compile-bool
    (concat "(" (ls-compile key env fenv) " in " (ls-compile object env fenv) ")")))
 
+(define-compilation functionp (x)
+  (compile-bool
+   (concat "(typeof " (ls-compile x env fenv) " == 'function')")))
+
+
 (defun macrop (x)
   (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
 
@@ -1015,8 +1037,7 @@
   (setq *toplevel-compilations* nil)
   (let ((code (ls-compile sexp nil nil)))
     (prog1
-        (concat  #+common-lisp (concat "/* " (princ-to-string sexp) " */")
-                (join (mapcar (lambda (x) (concat x ";" *newline*))
+        (concat (join (mapcar (lambda (x) (concat x ";" *newline*))
                               *toplevel-compilations*)
                "")
                 code)
@@ -1059,6 +1080,7 @@
  (js-eval
   (concat "var lisp = {};"
           "lisp.read = " (lookup-function-translation 'ls-read-from-string nil) ";" *newline*
+          "lisp.print = " (lookup-function-translation 'print-to-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*